Logo Search packages:      
Sourcecode: r-base version File versions

dlapack2.f

      SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
     $                   WORK, IWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     December 1, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          COMPQ, UPLO
      INTEGER            INFO, LDU, LDVT, N
*     ..
*     .. Array Arguments ..
      INTEGER            IQ( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), Q( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DBDSDC computes the singular value decomposition (SVD) of a real
*  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
*  using a divide and conquer method, where S is a diagonal matrix
*  with non-negative diagonal elements (the singular values of B), and
*  U and VT are orthogonal matrices of left and right singular vectors,
*  respectively. DBDSDC can be used to compute all singular values,
*  and optionally, singular vectors or singular vectors in compact form.
*
*  This code makes very mild assumptions about floating point
*  arithmetic. It will work on machines with a guard digit in
*  add/subtract, or on those binary machines without guard digits
*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
*  It could conceivably fail on hexadecimal or decimal machines
*  without guard digits, but we know of none.  See DLASD3 for details.
*
*  The code currently call DLASDQ if singular values only are desired.
*  However, it can be slightly modified to compute singular values
*  using the divide and conquer method.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  B is upper bidiagonal.
*          = 'L':  B is lower bidiagonal.
*
*  COMPQ   (input) CHARACTER*1
*          Specifies whether singular vectors are to be computed
*          as follows:
*          = 'N':  Compute singular values only;
*          = 'P':  Compute singular values and compute singular
*                  vectors in compact form;
*          = 'I':  Compute singular values and singular vectors.
*
*  N       (input) INTEGER
*          The order of the matrix B.  N >= 0.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the n diagonal elements of the bidiagonal matrix B.
*          On exit, if INFO=0, the singular values of B.
*
*  E       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the elements of E contain the offdiagonal
*          elements of the bidiagonal matrix whose SVD is desired.
*          On exit, E has been destroyed.
*
*  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
*          If  COMPQ = 'I', then:
*             On exit, if INFO = 0, U contains the left singular vectors
*             of the bidiagonal matrix.
*          For other values of COMPQ, U is not referenced.
*
*  LDU     (input) INTEGER
*          The leading dimension of the array U.  LDU >= 1.
*          If singular vectors are desired, then LDU >= max( 1, N ).
*
*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
*          If  COMPQ = 'I', then:
*             On exit, if INFO = 0, VT








' contains the right singular*             vectors of the bidiagonal matrix.*          For other values of COMPQ, VT is not referenced.**  LDVT    (input) INTEGER*          The leading dimension of the array VT.  LDVT >= 1.*          If singular vectors are desired, then LDVT >= max( 1, N ).**  Q       (output) DOUBLE PRECISION array, dimension (LDQ)*          If  COMPQ = 'P











', then:*             On exit, if INFO = 0, Q and IQ contain the left*             and right singular vectors in a compact form,*             requiring O(N log N) space instead of 2*N**2.*             In particular, Q contains all the DOUBLE PRECISION data in*             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))*             words of memory, where SMLSIZ is returned by ILAENV and*             is equal to the maximum size of the subproblems at the*             bottom of the computation tree (usually about 25).*          For other values of COMPQ, Q is not referenced.**  IQ      (output) INTEGER array, dimension (LDIQ)*          If  COMPQ = 'P











', then:*             On exit, if INFO = 0, Q and IQ contain the left*             and right singular vectors in a compact form,*             requiring O(N log N) space instead of 2*N**2.*             In particular, IQ contains all INTEGER data in*             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))*             words of memory, where SMLSIZ is returned by ILAENV and*             is equal to the maximum size of the subproblems at the*             bottom of the computation tree (usually about 25).*          For other values of COMPQ, IQ is not referenced.**  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)*          If COMPQ = 'N
' then LWORK >= (4 * N).*          If COMPQ = 'P
' then LWORK >= (6 * N).*          If COMPQ = 'I

















































' then LWORK >= (3 * N**2 + 4 * N).**  IWORK   (workspace) INTEGER array, dimension (8*N)**  INFO    (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.*          > 0:  The algorithm failed to compute an singular value.*                The update process of divide and conquer failed.**  Further Details*  ===============**  Based on contributions by*     Ming Gu and Huan Ren, Computer Science Division, University of*     California at Berkeley, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, ONE, TWO      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )*     ..*     .. Local Scalars ..      INTEGER            DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,     $                   ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,     $                   MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,     $                   SMLSZP, SQRE, START, WSTART, Z      DOUBLE PRECISION   CS, EPS, ORGNRM, P, R, SN*     ..*     .. External Functions ..      LOGICAL            LSAME      INTEGER            ILAENV      DOUBLE PRECISION   DLAMCH, DLANST      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ,     $                   DLASET, DLASR, DSWAP, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, DBLE, INT, LOG, SIGN*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IUPLO = 0      IF( LSAME( UPLO, 'U

' ) )     $   IUPLO = 1      IF( LSAME( UPLO, 'L

' ) )     $   IUPLO = 2      IF( LSAME( COMPQ, 'N

' ) ) THEN         ICOMPQ = 0      ELSE IF( LSAME( COMPQ, 'P

' ) ) THEN         ICOMPQ = 1      ELSE IF( LSAME( COMPQ, 'I


















' ) ) THEN         ICOMPQ = 2      ELSE         ICOMPQ = -1      END IF      IF( IUPLO.EQ.0 ) THEN         INFO = -1      ELSE IF( ICOMPQ.LT.0 ) THEN         INFO = -2      ELSE IF( N.LT.0 ) THEN         INFO = -3      ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.     $         N ) ) ) THEN         INFO = -7      ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.     $         N ) ) ) THEN         INFO = -9      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DBDSDC







', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 )     $   RETURN      SMLSIZ = ILAENV( 9, 'DBDSDC', ' 











































', 0, 0, 0, 0 )      IF( N.EQ.1 ) THEN         IF( ICOMPQ.EQ.1 ) THEN            Q( 1 ) = SIGN( ONE, D( 1 ) )            Q( 1+SMLSIZ*N ) = ONE         ELSE IF( ICOMPQ.EQ.2 ) THEN            U( 1, 1 ) = SIGN( ONE, D( 1 ) )            VT( 1, 1 ) = ONE         END IF         D( 1 ) = ABS( D( 1 ) )         RETURN      END IF      NM1 = N - 1**     If matrix lower bidiagonal, rotate to be upper bidiagonal*     by applying Givens rotations on the left*      WSTART = 1      QSTART = 3      IF( ICOMPQ.EQ.1 ) THEN         CALL DCOPY( N, D, 1, Q( 1 ), 1 )         CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 )      END IF      IF( IUPLO.EQ.2 ) THEN         QSTART = 5         WSTART = 2*N - 1         DO 10 I = 1, N - 1            CALL DLARTG( D( I ), E( I ), CS, SN, R )            D( I ) = R            E( I ) = SN*D( I+1 )            D( I+1 ) = CS*D( I+1 )            IF( ICOMPQ.EQ.1 ) THEN               Q( I+2*N ) = CS               Q( I+3*N ) = SN            ELSE IF( ICOMPQ.EQ.2 ) THEN               WORK( I ) = CS               WORK( NM1+I ) = -SN            END IF   10    CONTINUE      END IF**     If ICOMPQ = 0, use DLASDQ to compute the singular values.*      IF( ICOMPQ.EQ.0 ) THEN         CALL DLASDQ( 'U









', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,     $                LDU, WORK( WSTART ), INFO )         GO TO 40      END IF**     If N is smaller than the minimum divide size SMLSIZ, then solve*     the problem with another solver.*      IF( N.LE.SMLSIZ ) THEN         IF( ICOMPQ.EQ.2 ) THEN            CALL DLASET( 'A
', N, N, ZERO, ONE, U, LDU )            CALL DLASET( 'A
', N, N, ZERO, ONE, VT, LDVT )            CALL DLASDQ( 'U




', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,     $                   LDU, WORK( WSTART ), INFO )         ELSE IF( ICOMPQ.EQ.1 ) THEN            IU = 1            IVT = IU + N            CALL DLASET( 'A

', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),     $                   N )            CALL DLASET( 'A

', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),     $                   N )            CALL DLASDQ( 'U









', 0, N, N, N, 0, D, E,     $                   Q( IVT+( QSTART-1 )*N ), N,     $                   Q( IU+( QSTART-1 )*N ), N,     $                   Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),     $                   INFO )         END IF         GO TO 40      END IF*      IF( ICOMPQ.EQ.2 ) THEN         CALL DLASET( 'A
', N, N, ZERO, ONE, U, LDU )         CALL DLASET( 'A




', N, N, ZERO, ONE, VT, LDVT )      END IF**     Scale.*      ORGNRM = DLANST( 'M


', N, D, E )      IF( ORGNRM.EQ.ZERO )     $   RETURN      CALL DLASCL( 'G
', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )      CALL DLASCL( 'G

', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )*      EPS = DLAMCH( 'Epsilon


























































































' )*      MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1      SMLSZP = SMLSIZ + 1*      IF( ICOMPQ.EQ.1 ) THEN         IU = 1         IVT = 1 + SMLSIZ         DIFL = IVT + SMLSZP         DIFR = DIFL + MLVL         Z = DIFR + MLVL*2         IC = Z + MLVL         IS = IC + 1         POLES = IS + 1         GIVNUM = POLES + 2*MLVL*         K = 1         GIVPTR = 2         PERM = 3         GIVCOL = PERM + MLVL      END IF*      DO 20 I = 1, N         IF( ABS( D( I ) ).LT.EPS ) THEN            D( I ) = SIGN( EPS, D( I ) )         END IF   20 CONTINUE*      START = 1      SQRE = 0*      DO 30 I = 1, NM1         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN**        Subproblem found. First determine its size and then*        apply divide and conquer on it.*            IF( I.LT.NM1 ) THEN**        A subproblem with E(I) small for I < NM1.*               NSIZE = I - START + 1            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN**        A subproblem with E(NM1) not too small but I = NM1.*               NSIZE = N - START + 1            ELSE**        A subproblem with E(NM1) small. This implies an*        1-by-1 subproblem at D(N). Solve this 1-by-1 problem*        first.*               NSIZE = I - START + 1               IF( ICOMPQ.EQ.2 ) THEN                  U( N, N ) = SIGN( ONE, D( N ) )                  VT( N, N ) = ONE               ELSE IF( ICOMPQ.EQ.1 ) THEN                  Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )                  Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE               END IF               D( N ) = ABS( D( N ) )            END IF            IF( ICOMPQ.EQ.2 ) THEN               CALL DLASD0( NSIZE, SQRE, D( START ), E( START ),     $                      U( START, START ), LDU, VT( START, START ),     $                      LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )            ELSE               CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),     $                      E( START ), Q( START+( IU+QSTART-2 )*N ), N,     $                      Q( START+( IVT+QSTART-2 )*N ),     $                      IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*     $                      N ), Q( START+( DIFR+QSTART-2 )*N ),     $                      Q( START+( Z+QSTART-2 )*N ),     $                      Q( START+( POLES+QSTART-2 )*N ),     $                      IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),     $                      N, IQ( START+PERM*N ),     $                      Q( START+( GIVNUM+QSTART-2 )*N ),     $                      Q( START+( IC+QSTART-2 )*N ),     $                      Q( START+( IS+QSTART-2 )*N ),     $                      WORK( WSTART ), IWORK, INFO )               IF( INFO.NE.0 ) THEN                  RETURN               END IF            END IF            START = I + 1         END IF   30 CONTINUE**     Unscale*      CALL DLASCL( 'G










































', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )   40 CONTINUE**     Use Selection Sort to minimize swaps of singular vectors*      DO 60 II = 2, N         I = II - 1         KK = I         P = D( I )         DO 50 J = II, N            IF( D( J ).GT.P ) THEN               KK = J               P = D( J )            END IF   50    CONTINUE         IF( KK.NE.I ) THEN            D( KK ) = D( I )            D( I ) = P            IF( ICOMPQ.EQ.1 ) THEN               IQ( I ) = KK            ELSE IF( ICOMPQ.EQ.2 ) THEN               CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )               CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )            END IF         ELSE IF( ICOMPQ.EQ.1 ) THEN            IQ( I ) = I         END IF   60 CONTINUE**     If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO*      IF( ICOMPQ.EQ.1 ) THEN         IF( IUPLO.EQ.1 ) THEN            IQ( N ) = 1         ELSE            IQ( N ) = 0         END IF      END IF**     If B is lower bidiagonal, update U by those Givens rotations*     which rotated B to be upper bidiagonal*      IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )     $   CALL DLASR( 'L', 'V', 'B



























', N, N, WORK( 1 ), WORK( N ), U, LDU )*      RETURN**     End of DBDSDC*      END      SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,     $                   LDU, C, LDC, WORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     October 31, 1999**     .. Scalar Arguments ..      CHARACTER          UPLO      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU*     ..*     .. Array Arguments ..      DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ),     $                   VT( LDVT, * ), WORK( * )*     ..**  Purpose*  =======**  DBDSQR computes the singular value decomposition (SVD) of a real*  N-by-N (upper or lower) bidiagonal matrix B:  B = Q * S * P' (P




'*  denotes the transpose of P), where S is a diagonal matrix with*  non-negative diagonal elements (the singular values of B), and Q*  and P are orthogonal matrices.**  The routine computes S, and optionally computes U * Q, P' * VT,
*  or Q














' * C, for given real input matrices U, VT, and C.**  See "Computing  Small Singular Values of Bidiagonal Matrices With*  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,*  no. 5, pp. 873-912, Sept 1990) and*  "Accurate singular values and differential qd algorithms," by*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics*  Department, University of California at Berkeley, July 1992*  for a detailed description of the algorithm.**  Arguments*  =========**  UPLO    (input) CHARACTER*1*          = 'U
':  B is upper bidiagonal;*          = 'L





























':  B is lower bidiagonal.**  N       (input) INTEGER*          The order of the matrix B.  N >= 0.**  NCVT    (input) INTEGER*          The number of columns of the matrix VT. NCVT >= 0.**  NRU     (input) INTEGER*          The number of rows of the matrix U. NRU >= 0.**  NCC     (input) INTEGER*          The number of columns of the matrix C. NCC >= 0.**  D       (input/output) DOUBLE PRECISION array, dimension (N)*          On entry, the n diagonal elements of the bidiagonal matrix B.*          On exit, if INFO=0, the singular values of B in decreasing*          order.**  E       (input/output) DOUBLE PRECISION array, dimension (N)*          On entry, the elements of E contain the*          offdiagonal elements of the bidiagonal matrix whose SVD*          is desired. On normal exit (INFO = 0), E is destroyed.*          If the algorithm does not converge (INFO > 0), D and E*          will contain the diagonal and superdiagonal elements of a*          bidiagonal matrix orthogonally equivalent to the one given*          as input. E(N) is used for workspace.**  VT      (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)*          On entry, an N-by-NCVT matrix VT.*          On exit, VT is overwritten by P' * VT.
*          VT is not referenced if NCVT = 0.
*
*  LDVT    (input) INTEGER
*          The leading dimension of the array VT.
*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
*
*  U       (input/output) DOUBLE PRECISION array, dimension (LDU, N)
*          On entry, an NRU-by-N matrix U.
*          On exit, U is overwritten by U * Q.
*          U is not referenced if NRU = 0.
*
*  LDU     (input) INTEGER
*          The leading dimension of the array U.  LDU >= max(1,NRU).
*
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
*          On entry, an N-by-NCC matrix C.
*          On exit, C is overwritten by Q






















































































' * C.*          C is not referenced if NCC = 0.**  LDC     (input) INTEGER*          The leading dimension of the array C.*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.**  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  If INFO = -i, the i-th argument had an illegal value*          > 0:  the algorithm did not converge; D and E contain the*                elements of a bidiagonal matrix which is orthogonally*                similar to the input matrix B;  if INFO = i, i*                elements of E have not converged to zero.**  Internal Parameters*  ===================**  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))*          TOLMUL controls the convergence criterion of the QR loop.*          If it is positive, TOLMUL*EPS is the desired relative*             precision in the computed singular values.*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the*             desired absolute accuracy in the computed singular*             values (corresponds to relative accuracy*             abs(TOLMUL*EPS) in the largest singular value.*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably*             between 10 (for fast convergence) and .1/EPS*             (for there to be some accuracy in the results).*          Default is to lose at either one eighth or 2 of the*             available decimal digits in each computed singular value*             (whichever is smaller).**  MAXITR  INTEGER, default = 6*          MAXITR controls the maximum number of passes of the*          algorithm through its inner loop. The algorithms stops*          (and so fails to converge) if the number of passes*          through the inner loop exceeds MAXITR*N**2.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO      PARAMETER          ( ZERO = 0.0D0 )      DOUBLE PRECISION   ONE      PARAMETER          ( ONE = 1.0D0 )      DOUBLE PRECISION   NEGONE      PARAMETER          ( NEGONE = -1.0D0 )      DOUBLE PRECISION   HNDRTH      PARAMETER          ( HNDRTH = 0.01D0 )      DOUBLE PRECISION   TEN      PARAMETER          ( TEN = 10.0D0 )      DOUBLE PRECISION   HNDRD      PARAMETER          ( HNDRD = 100.0D0 )      DOUBLE PRECISION   MEIGTH      PARAMETER          ( MEIGTH = -0.125D0 )      INTEGER            MAXITR      PARAMETER          ( MAXITR = 6 )*     ..*     .. Local Scalars ..      LOGICAL            LOWER, ROTATE      INTEGER            I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,     $                   NM12, NM13, OLDLL, OLDM      DOUBLE PRECISION   ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,     $                   OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,     $                   SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA,     $                   SN, THRESH, TOL, TOLMUL, UNFL*     ..*     .. External Functions ..      LOGICAL            LSAME      DOUBLE PRECISION   DLAMCH      EXTERNAL           LSAME, DLAMCH*     ..*     .. External Subroutines ..      EXTERNAL           DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT,     $                   DSCAL, DSWAP, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, DBLE, MAX, MIN, SIGN, SQRT*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0      LOWER = LSAME( UPLO, 'L
' )      IF( .NOT.LSAME( UPLO, 'U



















' ) .AND. .NOT.LOWER ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( NCVT.LT.0 ) THEN         INFO = -3      ELSE IF( NRU.LT.0 ) THEN         INFO = -4      ELSE IF( NCC.LT.0 ) THEN         INFO = -5      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.     $         ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN         INFO = -9      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN         INFO = -11      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.     $         ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN         INFO = -13      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DBDSQR

























', -INFO )         RETURN      END IF      IF( N.EQ.0 )     $   RETURN      IF( N.EQ.1 )     $   GO TO 160**     ROTATE is true if any singular vectors desired, false otherwise*      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )**     If no singular vectors desired, use qd algorithm*      IF( .NOT.ROTATE ) THEN         CALL DLASQ1( N, D, E, WORK, INFO )         RETURN      END IF*      NM1 = N - 1      NM12 = NM1 + NM1      NM13 = NM12 + NM1      IDIR = 0**     Get machine constants*      EPS = DLAMCH( 'Epsilon
' )      UNFL = DLAMCH( 'Safe minimum

















' )**     If matrix lower bidiagonal, rotate to be upper bidiagonal*     by applying Givens rotations on the left*      IF( LOWER ) THEN         DO 10 I = 1, N - 1            CALL DLARTG( D( I ), E( I ), CS, SN, R )            D( I ) = R            E( I ) = SN*D( I+1 )            D( I+1 ) = CS*D( I+1 )            WORK( I ) = CS            WORK( NM1+I ) = SN   10    CONTINUE**        Update singular vectors if desired*         IF( NRU.GT.0 )     $      CALL DLASR( 'R', 'V', 'F


', NRU, N, WORK( 1 ), WORK( N ), U,     $                  LDU )         IF( NCC.GT.0 )     $      CALL DLASR( 'L', 'V', 'F












































































































































































































































































', N, NCC, WORK( 1 ), WORK( N ), C,     $                  LDC )      END IF**     Compute singular values to relative accuracy TOL*     (By setting TOL to be negative, algorithm will compute*     singular values to absolute accuracy ABS(TOL)*norm(input matrix))*      TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )      TOL = TOLMUL*EPS**     Compute approximate maximum, minimum singular values*      SMAX = ZERO      DO 20 I = 1, N         SMAX = MAX( SMAX, ABS( D( I ) ) )   20 CONTINUE      DO 30 I = 1, N - 1         SMAX = MAX( SMAX, ABS( E( I ) ) )   30 CONTINUE      SMINL = ZERO      IF( TOL.GE.ZERO ) THEN**        Relative accuracy desired*         SMINOA = ABS( D( 1 ) )         IF( SMINOA.EQ.ZERO )     $      GO TO 50         MU = SMINOA         DO 40 I = 2, N            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )            SMINOA = MIN( SMINOA, MU )            IF( SMINOA.EQ.ZERO )     $         GO TO 50   40    CONTINUE   50    CONTINUE         SMINOA = SMINOA / SQRT( DBLE( N ) )         THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )      ELSE**        Absolute accuracy desired*         THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )      END IF**     Prepare for main iteration loop for the singular values*     (MAXIT is the maximum number of passes through the inner*     loop permitted before nonconvergence signalled.)*      MAXIT = MAXITR*N*N      ITER = 0      OLDLL = -1      OLDM = -1**     M points to last element of unconverged part of matrix*      M = N**     Begin main iteration loop*   60 CONTINUE**     Check for convergence or exceeding iteration count*      IF( M.LE.1 )     $   GO TO 160      IF( ITER.GT.MAXIT )     $   GO TO 200**     Find diagonal block of matrix to work on*      IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )     $   D( M ) = ZERO      SMAX = ABS( D( M ) )      SMIN = SMAX      DO 70 LLL = 1, M - 1         LL = M - LLL         ABSS = ABS( D( LL ) )         ABSE = ABS( E( LL ) )         IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )     $      D( LL ) = ZERO         IF( ABSE.LE.THRESH )     $      GO TO 80         SMIN = MIN( SMIN, ABSS )         SMAX = MAX( SMAX, ABSS, ABSE )   70 CONTINUE      LL = 0      GO TO 90   80 CONTINUE      E( LL ) = ZERO**     Matrix splits since E(LL) = 0*      IF( LL.EQ.M-1 ) THEN**        Convergence of bottom singular value, return to top of loop*         M = M - 1         GO TO 60      END IF   90 CONTINUE      LL = LL + 1**     E(LL) through E(M-1) are nonzero, E(LL-1) is zero*      IF( LL.EQ.M-1 ) THEN**        2 by 2 block, handle separately*         CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,     $                COSR, SINL, COSL )         D( M-1 ) = SIGMX         E( M-1 ) = ZERO         D( M ) = SIGMN**        Compute singular vectors, if desired*         IF( NCVT.GT.0 )     $      CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,     $                 SINR )         IF( NRU.GT.0 )     $      CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )         IF( NCC.GT.0 )     $      CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,     $                 SINL )         M = M - 2         GO TO 60      END IF**     If working on new submatrix, choose shift direction*     (from larger end diagonal element towards smaller)*      IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN         IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN**           Chase bulge from top (big end) to bottom (small end)*            IDIR = 1         ELSE**           Chase bulge from bottom (big end) to top (small end)*            IDIR = 2         END IF      END IF**     Apply convergence tests*      IF( IDIR.EQ.1 ) THEN**        Run convergence test in forward direction*        First apply standard test to bottom of matrix*         IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.     $       ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN            E( M-1 ) = ZERO            GO TO 60         END IF*         IF( TOL.GE.ZERO ) THEN**           If relative accuracy desired,*           apply convergence criterion forward*            MU = ABS( D( LL ) )            SMINL = MU            DO 100 LLL = LL, M - 1               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN                  E( LLL ) = ZERO                  GO TO 60               END IF               SMINLO = SMINL               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )               SMINL = MIN( SMINL, MU )  100       CONTINUE         END IF*      ELSE**        Run convergence test in backward direction*        First apply standard test to top of matrix*         IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.     $       ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN            E( LL ) = ZERO            GO TO 60         END IF*         IF( TOL.GE.ZERO ) THEN**           If relative accuracy desired,*           apply convergence criterion backward*            MU = ABS( D( M ) )            SMINL = MU            DO 110 LLL = M - 1, LL, -1               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN                  E( LLL ) = ZERO                  GO TO 60               END IF               SMINLO = SMINL               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )               SMINL = MIN( SMINL, MU )  110       CONTINUE         END IF      END IF      OLDLL = LL      OLDM = M**     Compute shift.  First, test if shifting would ruin relative*     accuracy, and if so set the shift to zero.*      IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.     $    MAX( EPS, HNDRTH*TOL ) ) THEN**        Use a zero shift to avoid loss of relative accuracy*         SHIFT = ZERO      ELSE**        Compute the shift from 2-by-2 block at end of matrix*         IF( IDIR.EQ.1 ) THEN            SLL = ABS( D( LL ) )            CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )         ELSE            SLL = ABS( D( M ) )            CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )         END IF**        Test if shift negligible, and if so set to zero*         IF( SLL.GT.ZERO ) THEN            IF( ( SHIFT / SLL )**2.LT.EPS )     $         SHIFT = ZERO         END IF      END IF**     Increment iteration count*      ITER = ITER + M - LL**     If SHIFT = 0, do simplified QR iteration*      IF( SHIFT.EQ.ZERO ) THEN         IF( IDIR.EQ.1 ) THEN**           Chase bulge from top to bottom*           Save cosines and sines for later singular vector updates*            CS = ONE            OLDCS = ONE            DO 120 I = LL, M - 1               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )               IF( I.GT.LL )     $            E( I-1 ) = OLDSN*R               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )               WORK( I-LL+1 ) = CS               WORK( I-LL+1+NM1 ) = SN               WORK( I-LL+1+NM12 ) = OLDCS               WORK( I-LL+1+NM13 ) = OLDSN  120       CONTINUE            H = D( M )*CS            D( M ) = H*OLDCS            E( M-1 ) = H*OLDSN**           Update singular vectors*            IF( NCVT.GT.0 )     $         CALL DLASR( 'L', 'V', 'F


', M-LL+1, NCVT, WORK( 1 ),     $                     WORK( N ), VT( LL, 1 ), LDVT )            IF( NRU.GT.0 )     $         CALL DLASR( 'R', 'V', 'F


', NRU, M-LL+1, WORK( NM12+1 ),     $                     WORK( NM13+1 ), U( 1, LL ), LDU )            IF( NCC.GT.0 )     $         CALL DLASR( 'L', 'V', 'F































', M-LL+1, NCC, WORK( NM12+1 ),     $                     WORK( NM13+1 ), C( LL, 1 ), LDC )**           Test convergence*            IF( ABS( E( M-1 ) ).LE.THRESH )     $         E( M-1 ) = ZERO*         ELSE**           Chase bulge from bottom to top*           Save cosines and sines for later singular vector updates*            CS = ONE            OLDCS = ONE            DO 130 I = M, LL + 1, -1               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )               IF( I.LT.M )     $            E( I ) = OLDSN*R               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )               WORK( I-LL ) = CS               WORK( I-LL+NM1 ) = -SN               WORK( I-LL+NM12 ) = OLDCS               WORK( I-LL+NM13 ) = -OLDSN  130       CONTINUE            H = D( LL )*CS            D( LL ) = H*OLDCS            E( LL ) = H*OLDSN**           Update singular vectors*            IF( NCVT.GT.0 )     $         CALL DLASR( 'L', 'V', 'B


', M-LL+1, NCVT, WORK( NM12+1 ),     $                     WORK( NM13+1 ), VT( LL, 1 ), LDVT )            IF( NRU.GT.0 )     $         CALL DLASR( 'R', 'V', 'B


', NRU, M-LL+1, WORK( 1 ),     $                     WORK( N ), U( 1, LL ), LDU )            IF( NCC.GT.0 )     $         CALL DLASR( 'L', 'V', 'B













































', M-LL+1, NCC, WORK( 1 ),     $                     WORK( N ), C( LL, 1 ), LDC )**           Test convergence*            IF( ABS( E( LL ) ).LE.THRESH )     $         E( LL ) = ZERO         END IF      ELSE**        Use nonzero shift*         IF( IDIR.EQ.1 ) THEN**           Chase bulge from top to bottom*           Save cosines and sines for later singular vector updates*            F = ( ABS( D( LL ) )-SHIFT )*     $          ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )            G = E( LL )            DO 140 I = LL, M - 1               CALL DLARTG( F, G, COSR, SINR, R )               IF( I.GT.LL )     $            E( I-1 ) = R               F = COSR*D( I ) + SINR*E( I )               E( I ) = COSR*E( I ) - SINR*D( I )               G = SINR*D( I+1 )               D( I+1 ) = COSR*D( I+1 )               CALL DLARTG( F, G, COSL, SINL, R )               D( I ) = R               F = COSL*E( I ) + SINL*D( I+1 )               D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )               IF( I.LT.M-1 ) THEN                  G = SINL*E( I+1 )                  E( I+1 ) = COSL*E( I+1 )               END IF               WORK( I-LL+1 ) = COSR               WORK( I-LL+1+NM1 ) = SINR               WORK( I-LL+1+NM12 ) = COSL               WORK( I-LL+1+NM13 ) = SINL  140       CONTINUE            E( M-1 ) = F**           Update singular vectors*            IF( NCVT.GT.0 )     $         CALL DLASR( 'L', 'V', 'F


', M-LL+1, NCVT, WORK( 1 ),     $                     WORK( N ), VT( LL, 1 ), LDVT )            IF( NRU.GT.0 )     $         CALL DLASR( 'R', 'V', 'F


', NRU, M-LL+1, WORK( NM12+1 ),     $                     WORK( NM13+1 ), U( 1, LL ), LDU )            IF( NCC.GT.0 )     $         CALL DLASR( 'L', 'V', 'F














































', M-LL+1, NCC, WORK( NM12+1 ),     $                     WORK( NM13+1 ), C( LL, 1 ), LDC )**           Test convergence*            IF( ABS( E( M-1 ) ).LE.THRESH )     $         E( M-1 ) = ZERO*         ELSE**           Chase bulge from bottom to top*           Save cosines and sines for later singular vector updates*            F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /     $          D( M ) )            G = E( M-1 )            DO 150 I = M, LL + 1, -1               CALL DLARTG( F, G, COSR, SINR, R )               IF( I.LT.M )     $            E( I ) = R               F = COSR*D( I ) + SINR*E( I-1 )               E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )               G = SINR*D( I-1 )               D( I-1 ) = COSR*D( I-1 )               CALL DLARTG( F, G, COSL, SINL, R )               D( I ) = R               F = COSL*E( I-1 ) + SINL*D( I-1 )               D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )               IF( I.GT.LL+1 ) THEN                  G = SINL*E( I-2 )                  E( I-2 ) = COSL*E( I-2 )               END IF               WORK( I-LL ) = COSR               WORK( I-LL+NM1 ) = -SINR               WORK( I-LL+NM12 ) = COSL               WORK( I-LL+NM13 ) = -SINL  150       CONTINUE            E( LL ) = F**           Test convergence*            IF( ABS( E( LL ) ).LE.THRESH )     $         E( LL ) = ZERO**           Update singular vectors if desired*            IF( NCVT.GT.0 )     $         CALL DLASR( 'L', 'V', 'B


', M-LL+1, NCVT, WORK( NM12+1 ),     $                     WORK( NM13+1 ), VT( LL, 1 ), LDVT )            IF( NRU.GT.0 )     $         CALL DLASR( 'R', 'V', 'B


', NRU, M-LL+1, WORK( 1 ),     $                     WORK( N ), U( 1, LL ), LDU )            IF( NCC.GT.0 )     $         CALL DLASR( 'L', 'V', 'B

























































































', M-LL+1, NCC, WORK( 1 ),     $                     WORK( N ), C( LL, 1 ), LDC )         END IF      END IF**     QR iteration finished, go back and check convergence*      GO TO 60**     All singular values converged, so make them positive*  160 CONTINUE      DO 170 I = 1, N         IF( D( I ).LT.ZERO ) THEN            D( I ) = -D( I )**           Change sign of singular vectors, if desired*            IF( NCVT.GT.0 )     $         CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )         END IF  170 CONTINUE**     Sort the singular values into decreasing order (insertion sort on*     singular values, but only one transposition per singular vector)*      DO 190 I = 1, N - 1**        Scan for smallest D(I)*         ISUB = 1         SMIN = D( 1 )         DO 180 J = 2, N + 1 - I            IF( D( J ).LE.SMIN ) THEN               ISUB = J               SMIN = D( J )            END IF  180    CONTINUE         IF( ISUB.NE.N+1-I ) THEN**           Swap singular values and vectors*            D( ISUB ) = D( N+1-I )            D( N+1-I ) = SMIN            IF( NCVT.GT.0 )     $         CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),     $                     LDVT )            IF( NRU.GT.0 )     $         CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )            IF( NCC.GT.0 )     $         CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )         END IF  190 CONTINUE      GO TO 220**     Maximum number of iterations exceeded, failure to converge*  200 CONTINUE      INFO = 0      DO 210 I = 1, N - 1         IF( E( I ).NE.ZERO )     $      INFO = INFO + 1  210 CONTINUE  220 CONTINUE      RETURN**     End of DBDSQR*      END      SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          JOB      INTEGER            INFO, M, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   D( * ), SEP( * )*     ..**  Purpose*  =======**  DDISNA computes the reciprocal condition numbers for the eigenvectors*  of a real symmetric or complex Hermitian matrix or for the left or*  right singular vectors of a general m-by-n matrix. The reciprocal*  condition number is the 'gap





' between the corresponding eigenvalue or*  singular value and the nearest other one.**  The bound on the error, measured by angle in radians, in the I-th*  computed vector is given by**         DLAMCH( 'E


' ) * ( ANORM / SEP( I ) )**  where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed*  to be smaller than DLAMCH( 'E











' )*ANORM in order to limit the size of*  the error bound.**  DDISNA may also be used to compute error bounds for eigenvectors of*  the generalized symmetric definite eigenproblem.**  Arguments*  =========**  JOB     (input) CHARACTER*1*          Specifies for which problem the reciprocal condition numbers*          should be computed:*          = 'E
':  the eigenvectors of a symmetric/Hermitian matrix;*          = 'L
':  the left singular vectors of a general matrix;*          = 'R





':  the right singular vectors of a general matrix.**  M       (input) INTEGER*          The number of rows of the matrix. M >= 0.**  N       (input) INTEGER*          If JOB = 'L' or 'R
', the number of columns of the matrix,*          in which case N >= 0. Ignored if JOB = 'E

'.**  D       (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E
'*                              dimension (min(M,N)) if JOB = 'L' or 'R
'*          The eigenvalues (if JOB = 'E
') or singular values (if JOB =*          'L' or 'R


') of the matrix, in either increasing or decreasing*          order. If singular values, they must be non-negative.**  SEP     (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E
'*                               dimension (min(M,N)) if JOB = 'L' or 'R

































'*          The reciprocal condition numbers of the vectors.**  INFO    (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO      PARAMETER          ( ZERO = 0.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            DECR, EIGEN, INCR, LEFT, RIGHT, SING      INTEGER            I, K      DOUBLE PRECISION   ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH*     ..*     .. External Functions ..      LOGICAL            LSAME      DOUBLE PRECISION   DLAMCH      EXTERNAL           LSAME, DLAMCH*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN*     ..*     .. External Subroutines ..      EXTERNAL           XERBLA*     ..*     .. Executable Statements ..**     Test the input arguments*      INFO = 0      EIGEN = LSAME( JOB, 'E
' )      LEFT = LSAME( JOB, 'L
' )      RIGHT = LSAME( JOB, 'R































' )      SING = LEFT .OR. RIGHT      IF( EIGEN ) THEN         K = M      ELSE IF( SING ) THEN         K = MIN( M, N )      END IF      IF( .NOT.EIGEN .AND. .NOT.SING ) THEN         INFO = -1      ELSE IF( M.LT.0 ) THEN         INFO = -2      ELSE IF( K.LT.0 ) THEN         INFO = -3      ELSE         INCR = .TRUE.         DECR = .TRUE.         DO 10 I = 1, K - 1            IF( INCR )     $         INCR = INCR .AND. D( I ).LE.D( I+1 )            IF( DECR )     $         DECR = DECR .AND. D( I ).GE.D( I+1 )   10    CONTINUE         IF( SING .AND. K.GT.0 ) THEN            IF( INCR )     $         INCR = INCR .AND. ZERO.LE.D( 1 )            IF( DECR )     $         DECR = DECR .AND. D( K ).GE.ZERO         END IF         IF( .NOT.( INCR .OR. DECR ) )     $      INFO = -4      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DDISNA











', -INFO )         RETURN      END IF**     Quick return if possible*      IF( K.EQ.0 )     $   RETURN**     Compute reciprocal condition numbers*      IF( K.EQ.1 ) THEN         SEP( 1 ) = DLAMCH( 'O






















' )      ELSE         OLDGAP = ABS( D( 2 )-D( 1 ) )         SEP( 1 ) = OLDGAP         DO 20 I = 2, K - 1            NEWGAP = ABS( D( I+1 )-D( I ) )            SEP( I ) = MIN( OLDGAP, NEWGAP )            OLDGAP = NEWGAP   20    CONTINUE         SEP( K ) = OLDGAP      END IF      IF( SING ) THEN         IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN            IF( INCR )     $         SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) )            IF( DECR )     $         SEP( K ) = MIN( SEP( K ), D( K ) )         END IF      END IF**     Ensure that reciprocal condition numbers are not less than*     threshold, in order to limit the size of the error bound*      EPS = DLAMCH( 'E
' )      SAFMIN = DLAMCH( 'S




































' )      ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) )      IF( ANORM.EQ.ZERO ) THEN         THRESH = EPS      ELSE         THRESH = MAX( EPS*ANORM, SAFMIN )      END IF      DO 30 I = 1, K         SEP( I ) = MAX( SEP( I ), THRESH )   30 CONTINUE*      RETURN**     End of DDISNA*      END      SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,     $                   LDQ, PT, LDPT, C, LDC, WORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          VECT      INTEGER            INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC*     ..*     .. Array Arguments ..      DOUBLE PRECISION   AB( LDAB, * ), C( LDC, * ), D( * ), E( * ),     $                   PT( LDPT, * ), Q( LDQ, * ), WORK( * )*     ..**  Purpose*  =======**  DGBBRD reduces a real general m-by-n band matrix A to upper*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
*
*  The routine computes B, and optionally forms Q or P
', or computes*  Q'*C for a given matrix C.
*
*  Arguments
*  =========
*
*  VECT    (input) CHARACTER*1
*          Specifies whether or not the matrices Q and P

' are to be*          formed.*          = 'N': do not form Q or P';
*          = 'Q': form Q only;
*          = 'P': form P
' only;*          = 'B


































': form both.**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  NCC     (input) INTEGER*          The number of columns of the matrix C.  NCC >= 0.**  KL      (input) INTEGER*          The number of subdiagonals of the matrix A. KL >= 0.**  KU      (input) INTEGER*          The number of superdiagonals of the matrix A. KU >= 0.**  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)*          On entry, the m-by-n band matrix A, stored in rows 1 to*          KL+KU+1. The j-th column of A is stored in the j-th column of*          the array AB as follows:*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).*          On exit, A is overwritten by values generated during the*          reduction.**  LDAB    (input) INTEGER*          The leading dimension of the array A. LDAB >= KL+KU+1.**  D       (output) DOUBLE PRECISION array, dimension (min(M,N))*          The diagonal elements of the bidiagonal matrix B.**  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)*          The superdiagonal elements of the bidiagonal matrix B.**  Q       (output) DOUBLE PRECISION array, dimension (LDQ,M)*          If VECT = 'Q' or 'B
', the m-by-m orthogonal matrix Q.*          If VECT = 'N' or 'P



', the array Q is not referenced.**  LDQ     (input) INTEGER*          The leading dimension of the array Q.*          LDQ >= max(1,M) if VECT = 'Q' or 'B


'; LDQ >= 1 otherwise.**  PT      (output) DOUBLE PRECISION array, dimension (LDPT,N)*          If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
*          If VECT = 'N' or 'Q', the array PT is not referenced.
*
*  LDPT    (input) INTEGER
*          The leading dimension of the array PT.
*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
*
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)
*          On entry, an m-by-ncc matrix C.
*          On exit, C is overwritten by Q






































'*C.*          C is not referenced if NCC = 0.**  LDC     (input) INTEGER*          The leading dimension of the array C.*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.**  WORK    (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))**  INFO    (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, ONE      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            WANTB, WANTC, WANTPT, WANTQ      INTEGER            I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,     $                   KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT      DOUBLE PRECISION   RA, RB, RC, RS*     ..*     .. External Subroutines ..      EXTERNAL           DLARGV, DLARTG, DLARTV, DLASET, DROT, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. External Functions ..      LOGICAL            LSAME      EXTERNAL           LSAME*     ..*     .. Executable Statements ..**     Test the input parameters*      WANTB = LSAME( VECT, 'B
' )      WANTQ = LSAME( VECT, 'Q
' ) .OR. WANTB      WANTPT = LSAME( VECT, 'P



' ) .OR. WANTB      WANTC = NCC.GT.0      KLU1 = KL + KU + 1      INFO = 0      IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N






















' ) )     $     THEN         INFO = -1      ELSE IF( M.LT.0 ) THEN         INFO = -2      ELSE IF( N.LT.0 ) THEN         INFO = -3      ELSE IF( NCC.LT.0 ) THEN         INFO = -4      ELSE IF( KL.LT.0 ) THEN         INFO = -5      ELSE IF( KU.LT.0 ) THEN         INFO = -6      ELSE IF( LDAB.LT.KLU1 ) THEN         INFO = -8      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN         INFO = -12      ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN         INFO = -14      ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN         INFO = -16      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGBBRD



', -INFO )         RETURN      END IF**     Initialize Q and P' to the unit matrix, if needed
*
      IF( WANTQ )
     $   CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
      IF( WANTPT )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, PT, LDPT )
*
*     Quick return if possible.
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
      MINMN = MIN( M, N )
*
      IF( KL+KU.GT.1 ) THEN
*
*        Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
*        first to lower bidiagonal form and then transform to upper
*        bidiagonal
*
         IF( KU.GT.0 ) THEN
            ML0 = 1
            MU0 = 2
         ELSE
            ML0 = 2
            MU0 = 1
         END IF
*
*        Wherever possible, plane rotations are generated and applied in
*        vector operations of length NR over the index set J1:J2:KLU1.
*
*        The sines of the plane rotations are stored in WORK(1:max(m,n))
*        and the cosines in WORK(max(m,n)+1:2*max(m,n)).
*
         MN = MAX( M, N )
         KLM = MIN( M-1, KL )
         KUN = MIN( N-1, KU )
         KB = KLM + KUN
         KB1 = KB + 1
         INCA = KB1*LDAB
         NR = 0
         J1 = KLM + 2
         J2 = 1 - KUN
*
         DO 90 I = 1, MINMN
*
*           Reduce i-th column and i-th row of matrix to bidiagonal form
*
            ML = KLM + 1
            MU = KUN + 1
            DO 80 KK = 1, KB
               J1 = J1 + KB
               J2 = J2 + KB
*
*              generate plane rotations to annihilate nonzero elements
*              which have been created below the band
*
               IF( NR.GT.0 )
     $            CALL DLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
     $                         WORK( J1 ), KB1, WORK( MN+J1 ), KB1 )
*
*              apply plane rotations from the left
*
               DO 10 L = 1, KB
                  IF( J2-KLM+L-1.GT.N ) THEN
                     NRT = NR - 1
                  ELSE
                     NRT = NR
                  END IF
                  IF( NRT.GT.0 )
     $               CALL DLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
     $                            AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
     $                            WORK( MN+J1 ), WORK( J1 ), KB1 )
   10          CONTINUE
*
               IF( ML.GT.ML0 ) THEN
                  IF( ML.LE.M-I+1 ) THEN
*
*                    generate plane rotation to annihilate a(i+ml-1,i)
*                    within the band, and apply rotation from the left
*
                     CALL DLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
     $                            WORK( MN+I+ML-1 ), WORK( I+ML-1 ),
     $                            RA )
                     AB( KU+ML-1, I ) = RA
                     IF( I.LT.N )
     $                  CALL DROT( MIN( KU+ML-2, N-I ),
     $                             AB( KU+ML-2, I+1 ), LDAB-1,
     $                             AB( KU+ML-1, I+1 ), LDAB-1,
     $                             WORK( MN+I+ML-1 ), WORK( I+ML-1 ) )
                  END IF
                  NR = NR + 1
                  J1 = J1 - KB1
               END IF
*
               IF( WANTQ ) THEN
*
*                 accumulate product of plane rotations in Q
*
                  DO 20 J = J1, J2, KB1
                     CALL DROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
     $                          WORK( MN+J ), WORK( J ) )
   20             CONTINUE
               END IF
*
               IF( WANTC ) THEN
*
*                 apply plane rotations to C
*
                  DO 30 J = J1, J2, KB1
                     CALL DROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
     $                          WORK( MN+J ), WORK( J ) )
   30             CONTINUE
               END IF
*
               IF( J2+KUN.GT.N ) THEN
*
*                 adjust J2 to keep within the bounds of the matrix
*
                  NR = NR - 1
                  J2 = J2 - KB1
               END IF
*
               DO 40 J = J1, J2, KB1
*
*                 create nonzero element a(j-1,j+ku) above the band
*                 and store it in WORK(n+1:2*n)
*
                  WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
                  AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN )
   40          CONTINUE
*
*              generate plane rotations to annihilate nonzero elements
*              which have been generated above the band
*
               IF( NR.GT.0 )
     $            CALL DLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
     $                         WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ),
     $                         KB1 )
*
*              apply plane rotations from the right
*
               DO 50 L = 1, KB
                  IF( J2+L-1.GT.M ) THEN
                     NRT = NR - 1
                  ELSE
                     NRT = NR
                  END IF
                  IF( NRT.GT.0 )
     $               CALL DLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
     $                            AB( L, J1+KUN ), INCA,
     $                            WORK( MN+J1+KUN ), WORK( J1+KUN ),
     $                            KB1 )
   50          CONTINUE
*
               IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
                  IF( MU.LE.N-I+1 ) THEN
*
*                    generate plane rotation to annihilate a(i,i+mu-1)
*                    within the band, and apply rotation from the right
*
                     CALL DLARTG( AB( KU-MU+3, I+MU-2 ),
     $                            AB( KU-MU+2, I+MU-1 ),
     $                            WORK( MN+I+MU-1 ), WORK( I+MU-1 ),
     $                            RA )
                     AB( KU-MU+3, I+MU-2 ) = RA
                     CALL DROT( MIN( KL+MU-2, M-I ),
     $                          AB( KU-MU+4, I+MU-2 ), 1,
     $                          AB( KU-MU+3, I+MU-1 ), 1,
     $                          WORK( MN+I+MU-1 ), WORK( I+MU-1 ) )
                  END IF
                  NR = NR + 1
                  J1 = J1 - KB1
               END IF
*
               IF( WANTPT ) THEN
*
*                 accumulate product of plane rotations in P














































































































































'*                  DO 60 J = J1, J2, KB1                     CALL DROT( N, PT( J+KUN-1, 1 ), LDPT,     $                          PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ),     $                          WORK( J+KUN ) )   60             CONTINUE               END IF*               IF( J2+KB.GT.M ) THEN**                 adjust J2 to keep within the bounds of the matrix*                  NR = NR - 1                  J2 = J2 - KB1               END IF*               DO 70 J = J1, J2, KB1**                 create nonzero element a(j+kl+ku,j+ku-1) below the*                 band and store it in WORK(1:n)*                  WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )                  AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN )   70          CONTINUE*               IF( ML.GT.ML0 ) THEN                  ML = ML - 1               ELSE                  MU = MU - 1               END IF   80       CONTINUE   90    CONTINUE      END IF*      IF( KU.EQ.0 .AND. KL.GT.0 ) THEN**        A has been reduced to lower bidiagonal form**        Transform lower bidiagonal form to upper bidiagonal by applying*        plane rotations from the left, storing diagonal elements in D*        and off-diagonal elements in E*         DO 100 I = 1, MIN( M-1, N )            CALL DLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )            D( I ) = RA            IF( I.LT.N ) THEN               E( I ) = RS*AB( 1, I+1 )               AB( 1, I+1 ) = RC*AB( 1, I+1 )            END IF            IF( WANTQ )     $         CALL DROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS )            IF( WANTC )     $         CALL DROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,     $                    RS )  100    CONTINUE         IF( M.LE.N )     $      D( M ) = AB( 1, M )      ELSE IF( KU.GT.0 ) THEN**        A has been reduced to upper bidiagonal form*         IF( M.LT.N ) THEN**           Annihilate a(m,m+1) by applying plane rotations from the*           right, storing diagonal elements in D and off-diagonal*           elements in E*            RB = AB( KU, M+1 )            DO 110 I = M, 1, -1               CALL DLARTG( AB( KU+1, I ), RB, RC, RS, RA )               D( I ) = RA               IF( I.GT.1 ) THEN                  RB = -RS*AB( KU, I )                  E( I-1 ) = RC*AB( KU, I )               END IF               IF( WANTPT )     $            CALL DROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,     $                       RC, RS )  110       CONTINUE         ELSE**           Copy off-diagonal elements to E and diagonal elements to D*            DO 120 I = 1, MINMN - 1               E( I ) = AB( KU, I+1 )  120       CONTINUE            DO 130 I = 1, MINMN               D( I ) = AB( KU+1, I )  130       CONTINUE         END IF      ELSE**        A is diagonal. Set elements of E to zero and copy diagonal*        elements to D.*         DO 140 I = 1, MINMN - 1            E( I ) = ZERO  140    CONTINUE         DO 150 I = 1, MINMN            D( I ) = AB( 1, I )  150    CONTINUE      END IF      RETURN**     End of DGBBRD*      END      SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND,     $                   WORK, IWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          NORM      INTEGER            INFO, KL, KU, LDAB, N      DOUBLE PRECISION   ANORM, RCOND*     ..*     .. Array Arguments ..      INTEGER            IPIV( * ), IWORK( * )      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )*     ..**  Purpose*  =======**  DGBCON estimates the reciprocal of the condition number of a real*  general band matrix A, in either the 1-norm or the infinity-norm,*  using the LU factorization computed by DGBTRF.**  An estimate is obtained for norm(inv(A)), and the reciprocal of the*  condition number is computed as*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).**  Arguments*  =========**  NORM    (input) CHARACTER*1*          Specifies whether the 1-norm condition number or the*          infinity-norm condition number is required:*          = '1' or 'O
':  1-norm;*          = 'I

























':         Infinity-norm.**  N       (input) INTEGER*          The order of the matrix A.  N >= 0.**  KL      (input) INTEGER*          The number of subdiagonals within the band of A.  KL >= 0.**  KU      (input) INTEGER*          The number of superdiagonals within the band of A.  KU >= 0.**  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)*          Details of the LU factorization of the band matrix A, as*          computed by DGBTRF.  U is stored as an upper triangular band*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and*          the multipliers used during the factorization are stored in*          rows KL+KU+2 to 2*KL+KU+1.**  LDAB    (input) INTEGER*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.**  IPIV    (input) INTEGER array, dimension (N)*          The pivot indices; for 1 <= i <= N, row i of the matrix was*          interchanged with row IPIV(i).**  ANORM   (input) DOUBLE PRECISION*          If NORM = '1' or 'O
', the 1-norm of the original matrix A.*          If NORM = 'I










































', the infinity-norm of the original matrix A.**  RCOND   (output) DOUBLE PRECISION*          The reciprocal of the condition number of the matrix A,*          computed as RCOND = 1/(norm(A) * norm(inv(A))).**  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)**  IWORK   (workspace) INTEGER array, dimension (N)**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0: if INFO = -i, the i-th argument had an illegal value**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            LNOTI, ONENRM      CHARACTER          NORMIN      INTEGER            IX, J, JP, KASE, KASE1, KD, LM      DOUBLE PRECISION   AINVNM, SCALE, SMLNUM, T*     ..*     .. External Functions ..      LOGICAL            LSAME      INTEGER            IDAMAX      DOUBLE PRECISION   DDOT, DLAMCH      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH*     ..*     .. External Subroutines ..      EXTERNAL           DAXPY, DLACON, DLATBS, DRSCL, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MIN*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O
' )      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I













' ) ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( KL.LT.0 ) THEN         INFO = -3      ELSE IF( KU.LT.0 ) THEN         INFO = -4      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN         INFO = -6      ELSE IF( ANORM.LT.ZERO ) THEN         INFO = -8      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGBCON













', -INFO )         RETURN      END IF**     Quick return if possible*      RCOND = ZERO      IF( N.EQ.0 ) THEN         RCOND = ONE         RETURN      ELSE IF( ANORM.EQ.ZERO ) THEN         RETURN      END IF*      SMLNUM = DLAMCH( 'Safe minimum




' )**     Estimate the norm of inv(A).*      AINVNM = ZERO      NORMIN = 'N






























'      IF( ONENRM ) THEN         KASE1 = 1      ELSE         KASE1 = 2      END IF      KD = KL + KU + 1      LNOTI = KL.GT.0      KASE = 0   10 CONTINUE      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )      IF( KASE.NE.0 ) THEN         IF( KASE.EQ.KASE1 ) THEN**           Multiply by inv(L).*            IF( LNOTI ) THEN               DO 20 J = 1, N - 1                  LM = MIN( KL, N-J )                  JP = IPIV( J )                  T = WORK( JP )                  IF( JP.NE.J ) THEN                     WORK( JP ) = WORK( J )                     WORK( J ) = T                  END IF                  CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )   20          CONTINUE            END IF**           Multiply by inv(U).*            CALL DLATBS( 'Upper', 'No transpose', 'Non-unit




', NORMIN, N,     $                   KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),     $                   INFO )         ELSE**           Multiply by inv(U').
*
            CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
     $                   KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
     $                   INFO )
*
*           Multiply by inv(L


















').*            IF( LNOTI ) THEN               DO 30 J = N - 1, 1, -1                  LM = MIN( KL, N-J )                  WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1,     $                        WORK( J+1 ), 1 )                  JP = IPIV( J )                  IF( JP.NE.J ) THEN                     T = WORK( JP )                     WORK( JP ) = WORK( J )                     WORK( J ) = T                  END IF   30          CONTINUE            END IF         END IF**        Divide X by 1/SCALE if doing so will not cause overflow.*         NORMIN = 'Y













































































































































'         IF( SCALE.NE.ONE ) THEN            IX = IDAMAX( N, WORK, 1 )            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )     $         GO TO 40            CALL DRSCL( N, SCALE, WORK, 1 )         END IF         GO TO 10      END IF**     Compute the estimate of the reciprocal condition number.*      IF( AINVNM.NE.ZERO )     $   RCOND = ( ONE / AINVNM ) / ANORM*   40 CONTINUE      RETURN**     End of DGBCON*      END      SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,     $                   AMAX, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     March 31, 1993**     .. Scalar Arguments ..      INTEGER            INFO, KL, KU, LDAB, M, N      DOUBLE PRECISION   AMAX, COLCND, ROWCND*     ..*     .. Array Arguments ..      DOUBLE PRECISION   AB( LDAB, * ), C( * ), R( * )*     ..**  Purpose*  =======**  DGBEQU computes row and column scalings intended to equilibrate an*  M-by-N band matrix A and reduce its condition number.  R returns the*  row scale factors and C the column scale factors, chosen to try to*  make the largest element in each row and column of the matrix B with*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.**  R(i) and C(j) are restricted to be between SMLNUM = smallest safe*  number and BIGNUM = largest safe number.  Use of these scaling*  factors is not guaranteed to reduce the condition number of A but*  works well in practice.**  Arguments*  =========**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  KL      (input) INTEGER*          The number of subdiagonals within the band of A.  KL >= 0.**  KU      (input) INTEGER*          The number of superdiagonals within the band of A.  KU >= 0.**  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th*          column of A is stored in the j-th column of the array AB as*          follows:*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).**  LDAB    (input) INTEGER*          The leading dimension of the array AB.  LDAB >= KL+KU+1.**  R       (output) DOUBLE PRECISION array, dimension (M)*          If INFO = 0, or INFO > M, R contains the row scale factors*          for A.**  C       (output) DOUBLE PRECISION array, dimension (N)*          If INFO = 0, C contains the column scale factors for A.**  ROWCND  (output) DOUBLE PRECISION*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and*          AMAX is neither too large nor too small, it is not worth*          scaling by R.**  COLCND  (output) DOUBLE PRECISION*          If INFO = 0, COLCND contains the ratio of the smallest*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not*          worth scaling by C.**  AMAX    (output) DOUBLE PRECISION*          Absolute value of largest matrix element.  If AMAX is very*          close to overflow or very close to underflow, the matrix*          should be scaled.**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value*          > 0:  if INFO = i, and i is*                <= M:  the i-th row of A is exactly zero*                >  M:  the (i-M)-th column of A is exactly zero**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )*     ..*     .. Local Scalars ..      INTEGER            I, J, KD      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM*     ..*     .. External Functions ..      DOUBLE PRECISION   DLAMCH      EXTERNAL           DLAMCH*     ..*     .. External Subroutines ..      EXTERNAL           XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN*     ..*     .. Executable Statements ..**     Test the input parameters*      INFO = 0      IF( M.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( KL.LT.0 ) THEN         INFO = -3      ELSE IF( KU.LT.0 ) THEN         INFO = -4      ELSE IF( LDAB.LT.KL+KU+1 ) THEN         INFO = -6      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGBEQU














', -INFO )         RETURN      END IF**     Quick return if possible*      IF( M.EQ.0 .OR. N.EQ.0 ) THEN         ROWCND = ONE         COLCND = ONE         AMAX = ZERO         RETURN      END IF**     Get machine constants.*      SMLNUM = DLAMCH( 'S






































































































































' )      BIGNUM = ONE / SMLNUM**     Compute row scale factors.*      DO 10 I = 1, M         R( I ) = ZERO   10 CONTINUE**     Find the maximum element in each row.*      KD = KU + 1      DO 30 J = 1, N         DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )            R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) )   20    CONTINUE   30 CONTINUE**     Find the maximum and minimum scale factors.*      RCMIN = BIGNUM      RCMAX = ZERO      DO 40 I = 1, M         RCMAX = MAX( RCMAX, R( I ) )         RCMIN = MIN( RCMIN, R( I ) )   40 CONTINUE      AMAX = RCMAX*      IF( RCMIN.EQ.ZERO ) THEN**        Find the first zero scale factor and return an error code.*         DO 50 I = 1, M            IF( R( I ).EQ.ZERO ) THEN               INFO = I               RETURN            END IF   50    CONTINUE      ELSE**        Invert the scale factors.*         DO 60 I = 1, M            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )   60    CONTINUE**        Compute ROWCND = min(R(I)) / max(R(I))*         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )      END IF**     Compute column scale factors*      DO 70 J = 1, N         C( J ) = ZERO   70 CONTINUE**     Find the maximum element in each column,*     assuming the row scaling computed above.*      KD = KU + 1      DO 90 J = 1, N         DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )            C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) )   80    CONTINUE   90 CONTINUE**     Find the maximum and minimum scale factors.*      RCMIN = BIGNUM      RCMAX = ZERO      DO 100 J = 1, N         RCMIN = MIN( RCMIN, C( J ) )         RCMAX = MAX( RCMAX, C( J ) )  100 CONTINUE*      IF( RCMIN.EQ.ZERO ) THEN**        Find the first zero scale factor and return an error code.*         DO 110 J = 1, N            IF( C( J ).EQ.ZERO ) THEN               INFO = M + J               RETURN            END IF  110    CONTINUE      ELSE**        Invert the scale factors.*         DO 120 J = 1, N            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )  120    CONTINUE**        Compute COLCND = min(C(J)) / max(C(J))*         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )      END IF*      RETURN**     End of DGBEQU*      END      SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,     $                   IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,     $                   INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          TRANS      INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS*     ..*     .. Array Arguments ..      INTEGER            IPIV( * ), IWORK( * )      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )*     ..**  Purpose*  =======**  DGBRFS improves the computed solution to a system of linear*  equations when the coefficient matrix is banded, and provides*  error bounds and backward error estimates for the solution.**  Arguments*  =========**  TRANS   (input) CHARACTER*1*          Specifies the form of the system of equations:*          = 'N
':  A * X = B     (No transpose)*          = 'T
':  A**T * X = B  (Transpose)*          = 'C


















































































































':  A**H * X = B  (Conjugate transpose = Transpose)**  N       (input) INTEGER*          The order of the matrix A.  N >= 0.**  KL      (input) INTEGER*          The number of subdiagonals within the band of A.  KL >= 0.**  KU      (input) INTEGER*          The number of superdiagonals within the band of A.  KU >= 0.**  NRHS    (input) INTEGER*          The number of right hand sides, i.e., the number of columns*          of the matrices B and X.  NRHS >= 0.**  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)*          The original band matrix A, stored in rows 1 to KL+KU+1.*          The j-th column of A is stored in the j-th column of the*          array AB as follows:*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).**  LDAB    (input) INTEGER*          The leading dimension of the array AB.  LDAB >= KL+KU+1.**  AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)*          Details of the LU factorization of the band matrix A, as*          computed by DGBTRF.  U is stored as an upper triangular band*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and*          the multipliers used during the factorization are stored in*          rows KL+KU+2 to 2*KL+KU+1.**  LDAFB   (input) INTEGER*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.**  IPIV    (input) INTEGER array, dimension (N)*          The pivot indices from DGBTRF; for 1<=i<=N, row i of the*          matrix was interchanged with row IPIV(i).**  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)*          The right hand side matrix B.**  LDB     (input) INTEGER*          The leading dimension of the array B.  LDB >= max(1,N).**  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)*          On entry, the solution matrix X, as computed by DGBTRS.*          On exit, the improved solution matrix X.**  LDX     (input) INTEGER*          The leading dimension of the array X.  LDX >= max(1,N).**  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)*          The estimated forward error bound for each solution vector*          X(j) (the j-th column of the solution matrix X).*          If XTRUE is the true solution corresponding to X(j), FERR(j)*          is an estimated upper bound for the magnitude of the largest*          element in (X(j) - XTRUE) divided by the magnitude of the*          largest element in X(j).  The estimate is as reliable as*          the estimate for RCOND, and is almost always a slight*          overestimate of the true error.**  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)*          The componentwise relative backward error of each solution*          vector X(j) (i.e., the smallest relative change in*          any element of A or B that makes X(j) an exact solution).**  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)**  IWORK   (workspace) INTEGER array, dimension (N)**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value**  Internal Parameters*  ===================**  ITMAX is the maximum number of steps of iterative refinement.**  =====================================================================**     .. Parameters ..      INTEGER            ITMAX      PARAMETER          ( ITMAX = 5 )      DOUBLE PRECISION   ZERO      PARAMETER          ( ZERO = 0.0D+0 )      DOUBLE PRECISION   ONE      PARAMETER          ( ONE = 1.0D+0 )      DOUBLE PRECISION   TWO      PARAMETER          ( TWO = 2.0D+0 )      DOUBLE PRECISION   THREE      PARAMETER          ( THREE = 3.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            NOTRAN      CHARACTER          TRANST      INTEGER            COUNT, I, J, K, KASE, KK, NZ      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK*     ..*     .. External Subroutines ..      EXTERNAL           DAXPY, DCOPY, DGBMV, DGBTRS, DLACON, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN*     ..*     .. External Functions ..      LOGICAL            LSAME      DOUBLE PRECISION   DLAMCH      EXTERNAL           LSAME, DLAMCH*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0      NOTRAN = LSAME( TRANS, 'N
' )      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T
' ) .AND. .NOT.     $    LSAME( TRANS, 'C



















' ) ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( KL.LT.0 ) THEN         INFO = -3      ELSE IF( KU.LT.0 ) THEN         INFO = -4      ELSE IF( NRHS.LT.0 ) THEN         INFO = -5      ELSE IF( LDAB.LT.KL+KU+1 ) THEN         INFO = -7      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN         INFO = -9      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN         INFO = -12      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN         INFO = -14      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGBRFS














', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN         DO 10 J = 1, NRHS            FERR( J ) = ZERO            BERR( J ) = ZERO   10    CONTINUE         RETURN      END IF*      IF( NOTRAN ) THEN         TRANST = 'T

'      ELSE         TRANST = 'N





'      END IF**     NZ = maximum number of nonzero elements in each row of A, plus 1*      NZ = MIN( KL+KU+2, N+1 )      EPS = DLAMCH( 'Epsilon
' )      SAFMIN = DLAMCH( 'Safe minimum



























































































































































































































































































' )      SAFE1 = NZ*SAFMIN      SAFE2 = SAFE1 / EPS**     Do for each right hand side*      DO 140 J = 1, NRHS*         COUNT = 1         LSTRES = THREE   20    CONTINUE**        Loop until stopping criterion is satisfied.**        Compute residual R = B - op(A) * X,*        where op(A) = A, A**T, or A**H, depending on TRANS.*         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )         CALL DGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1,     $               ONE, WORK( N+1 ), 1 )**        Compute componentwise relative backward error from formula**        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )**        where abs(Z) is the componentwise absolute value of the matrix*        or vector Z.  If the i-th component of the denominator is less*        than SAFE2, then SAFE1 is added to the i-th components of the*        numerator and denominator before dividing.*         DO 30 I = 1, N            WORK( I ) = ABS( B( I, J ) )   30    CONTINUE**        Compute abs(op(A))*abs(X) + abs(B).*         IF( NOTRAN ) THEN            DO 50 K = 1, N               KK = KU + 1 - K               XK = ABS( X( K, J ) )               DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )                  WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK   40          CONTINUE   50       CONTINUE         ELSE            DO 70 K = 1, N               S = ZERO               KK = KU + 1 - K               DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )                  S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) )   60          CONTINUE               WORK( K ) = WORK( K ) + S   70       CONTINUE         END IF         S = ZERO         DO 80 I = 1, N            IF( WORK( I ).GT.SAFE2 ) THEN               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )            ELSE               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /     $             ( WORK( I )+SAFE1 ) )            END IF   80    CONTINUE         BERR( J ) = S**        Test stopping criterion. Continue iterating if*           1) The residual BERR(J) is larger than machine epsilon, and*           2) BERR(J) decreased by at least a factor of 2 during the*              last iteration, and*           3) At most ITMAX iterations tried.*         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.     $       COUNT.LE.ITMAX ) THEN**           Update solution and try again.*            CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,     $                   WORK( N+1 ), N, INFO )            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )            LSTRES = BERR( J )            COUNT = COUNT + 1            GO TO 20         END IF**        Bound error from formula**        norm(X - XTRUE) / norm(X) .le. FERR =*        norm( abs(inv(op(A)))**           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)**        where*          norm(Z) is the magnitude of the largest component of Z*          inv(op(A)) is the inverse of op(A)*          abs(Z) is the componentwise absolute value of the matrix or*             vector Z*          NZ is the maximum number of nonzeros in any row of A, plus 1*          EPS is machine epsilon**        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))*        is incremented by SAFE1 if the i-th component of*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.**        Use DLACON to estimate the infinity-norm of the matrix*           inv(op(A)) * diag(W),*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))*         DO 90 I = 1, N            IF( WORK( I ).GT.SAFE2 ) THEN               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )            ELSE               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1            END IF   90    CONTINUE*         KASE = 0  100    CONTINUE         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),     $                KASE )         IF( KASE.NE.0 ) THEN            IF( KASE.EQ.1 ) THEN**              Multiply by diag(W)*inv(op(A)**T).*               CALL DGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,     $                      WORK( N+1 ), N, INFO )               DO 110 I = 1, N                  WORK( N+I ) = WORK( N+I )*WORK( I )  110          CONTINUE            ELSE**              Multiply by inv(op(A))*diag(W).*               DO 120 I = 1, N                  WORK( N+I ) = WORK( N+I )*WORK( I )  120          CONTINUE               CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,     $                      WORK( N+1 ), N, INFO )            END IF            GO TO 100         END IF**        Normalize error.*         LSTRES = ZERO         DO 130 I = 1, N            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )  130    CONTINUE         IF( LSTRES.NE.ZERO )     $      FERR( J ) = FERR( J ) / LSTRES*  140 CONTINUE*      RETURN**     End of DGBRFS*      END      SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     February 29, 1992**     .. Scalar Arguments ..      INTEGER            INFO, KL, KU, LDAB, M, N*     ..*     .. Array Arguments ..      INTEGER            IPIV( * )      DOUBLE PRECISION   AB( LDAB, * )*     ..**  Purpose*  =======**  DGBTF2 computes an LU factorization of a real m-by-n band matrix A*  using partial pivoting with row interchanges.**  This is the unblocked version of the algorithm, calling Level 2 BLAS.**  Arguments*  =========**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  KL      (input) INTEGER*          The number of subdiagonals within the band of A.  KL >= 0.**  KU      (input) INTEGER*          The number of superdiagonals within the band of A.  KU >= 0.**  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)*          On entry, the matrix A in band storage, in rows KL+1 to*          2*KL+KU+1; rows 1 to KL of the array need not be set.*          The j-th column of A is stored in the j-th column of the*          array AB as follows:*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)**          On exit, details of the factorization: U is stored as an*          upper triangular band matrix with KL+KU superdiagonals in*          rows 1 to KL+KU+1, and the multipliers used during the*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.*          See below for further details.**  LDAB    (input) INTEGER*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.**  IPIV    (output) INTEGER array, dimension (min(M,N))*          The pivot indices; for 1 <= i <= min(M,N), row i of the*          matrix was interchanged with row IPIV(i).**  INFO    (output) INTEGER*          = 0: successful exit*          < 0: if INFO = -i, the i-th argument had an illegal value*          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization*               has been completed, but the factor U is exactly*               singular, and division by zero will occur if it is used*               to solve a system of equations.**  Further Details*  ===============**  The band storage scheme is illustrated by the following example, when*  M = N = 6, KL = 2, KU = 1:**  On entry:                       On exit:**      *    *    *    +    +    +       *    *    *   u14  u25  u36*      *    *    +    +    +    +       *    *   u13  u24  u35  u46*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   **     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    ***  Array elements marked * are not used by the routine; elements marked*  + need not be set on entry, but are required by the routine to store*  elements of U, because of fill-in resulting from the row*  interchanges.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )*     ..*     .. Local Scalars ..      INTEGER            I, J, JP, JU, KM, KV*     ..*     .. External Functions ..      INTEGER            IDAMAX      EXTERNAL           IDAMAX*     ..*     .. External Subroutines ..      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..**     KV is the number of superdiagonals in the factor U, allowing for*     fill-in.*      KV = KU + KL**     Test the input parameters.*      INFO = 0      IF( M.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( KL.LT.0 ) THEN         INFO = -3      ELSE IF( KU.LT.0 ) THEN         INFO = -4      ELSE IF( LDAB.LT.KL+KV+1 ) THEN         INFO = -6      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGBTF2


















































































































































































































', -INFO )         RETURN      END IF**     Quick return if possible*      IF( M.EQ.0 .OR. N.EQ.0 )     $   RETURN**     Gaussian elimination with partial pivoting**     Set fill-in elements in columns KU+2 to KV to zero.*      DO 20 J = KU + 2, MIN( KV, N )         DO 10 I = KV - J + 2, KL            AB( I, J ) = ZERO   10    CONTINUE   20 CONTINUE**     JU is the index of the last column affected by the current stage*     of the factorization.*      JU = 1*      DO 40 J = 1, MIN( M, N )**        Set fill-in elements in column J+KV to zero.*         IF( J+KV.LE.N ) THEN            DO 30 I = 1, KL               AB( I, J+KV ) = ZERO   30       CONTINUE         END IF**        Find pivot and test for singularity. KM is the number of*        subdiagonal elements in the current column.*         KM = MIN( KL, M-J )         JP = IDAMAX( KM+1, AB( KV+1, J ), 1 )         IPIV( J ) = JP + J - 1         IF( AB( KV+JP, J ).NE.ZERO ) THEN            JU = MAX( JU, MIN( J+KU+JP-1, N ) )**           Apply interchange to columns J to JU.*            IF( JP.NE.1 )     $         CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,     $                     AB( KV+1, J ), LDAB-1 )*            IF( KM.GT.0 ) THEN**              Compute multipliers.*               CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )**              Update trailing submatrix within the band.*               IF( JU.GT.J )     $            CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,     $                       AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),     $                       LDAB-1 )            END IF         ELSE**           If pivot is zero, set INFO to the index of the pivot*           unless a zero pivot has already been found.*            IF( INFO.EQ.0 )     $         INFO = J         END IF   40 CONTINUE      RETURN**     End of DGBTF2*      END      SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     February 29, 1992**     .. Scalar Arguments ..      INTEGER            INFO, KL, KU, LDAB, M, N*     ..*     .. Array Arguments ..      INTEGER            IPIV( * )      DOUBLE PRECISION   AB( LDAB, * )*     ..**  Purpose*  =======**  DGBTRF computes an LU factorization of a real m-by-n band matrix A*  using partial pivoting with row interchanges.**  This is the blocked version of the algorithm, calling Level 3 BLAS.**  Arguments*  =========**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  KL      (input) INTEGER*          The number of subdiagonals within the band of A.  KL >= 0.**  KU      (input) INTEGER*          The number of superdiagonals within the band of A.  KU >= 0.**  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)*          On entry, the matrix A in band storage, in rows KL+1 to*          2*KL+KU+1; rows 1 to KL of the array need not be set.*          The j-th column of A is stored in the j-th column of the*          array AB as follows:*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)**          On exit, details of the factorization: U is stored as an*          upper triangular band matrix with KL+KU superdiagonals in*          rows 1 to KL+KU+1, and the multipliers used during the*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.*          See below for further details.**  LDAB    (input) INTEGER*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.**  IPIV    (output) INTEGER array, dimension (min(M,N))*          The pivot indices; for 1 <= i <= min(M,N), row i of the*          matrix was interchanged with row IPIV(i).**  INFO    (output) INTEGER*          = 0: successful exit*          < 0: if INFO = -i, the i-th argument had an illegal value*          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization*               has been completed, but the factor U is exactly*               singular, and division by zero will occur if it is used*               to solve a system of equations.**  Further Details*  ===============**  The band storage scheme is illustrated by the following example, when*  M = N = 6, KL = 2, KU = 1:**  On entry:                       On exit:**      *    *    *    +    +    +       *    *    *   u14  u25  u36*      *    *    +    +    +    +       *    *   u13  u24  u35  u46*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   **     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    ***  Array elements marked * are not used by the routine; elements marked*  + need not be set on entry, but are required by the routine to store*  elements of U because of fill-in resulting from the row interchanges.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )      INTEGER            NBMAX, LDWORK      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )*     ..*     .. Local Scalars ..      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,     $                   JU, K2, KM, KV, NB, NW      DOUBLE PRECISION   TEMP*     ..*     .. Local Arrays ..      DOUBLE PRECISION   WORK13( LDWORK, NBMAX ),     $                   WORK31( LDWORK, NBMAX )*     ..*     .. External Functions ..      INTEGER            IDAMAX, ILAENV      EXTERNAL           IDAMAX, ILAENV*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL,     $                   DSWAP, DTRSM, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..**     KV is the number of superdiagonals in the factor U, allowing for*     fill-in*      KV = KU + KL**     Test the input parameters.*      INFO = 0      IF( M.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( KL.LT.0 ) THEN         INFO = -3      ELSE IF( KU.LT.0 ) THEN         INFO = -4      ELSE IF( LDAB.LT.KL+KV+1 ) THEN         INFO = -6      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGBTRF










', -INFO )         RETURN      END IF**     Quick return if possible*      IF( M.EQ.0 .OR. N.EQ.0 )     $   RETURN**     Determine the block size for this environment*      NB = ILAENV( 1, 'DGBTRF', ' 

















































































































































































', M, N, KL, KU )**     The block size must not exceed the limit set by the size of the*     local arrays WORK13 and WORK31.*      NB = MIN( NB, NBMAX )*      IF( NB.LE.1 .OR. NB.GT.KL ) THEN**        Use unblocked code*         CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )      ELSE**        Use blocked code**        Zero the superdiagonal elements of the work array WORK13*         DO 20 J = 1, NB            DO 10 I = 1, J - 1               WORK13( I, J ) = ZERO   10       CONTINUE   20    CONTINUE**        Zero the subdiagonal elements of the work array WORK31*         DO 40 J = 1, NB            DO 30 I = J + 1, NB               WORK31( I, J ) = ZERO   30       CONTINUE   40    CONTINUE**        Gaussian elimination with partial pivoting**        Set fill-in elements in columns KU+2 to KV to zero*         DO 60 J = KU + 2, MIN( KV, N )            DO 50 I = KV - J + 2, KL               AB( I, J ) = ZERO   50       CONTINUE   60    CONTINUE**        JU is the index of the last column affected by the current*        stage of the factorization*         JU = 1*         DO 180 J = 1, MIN( M, N ), NB            JB = MIN( NB, MIN( M, N )-J+1 )**           The active part of the matrix is partitioned**              A11   A12   A13*              A21   A22   A23*              A31   A32   A33**           Here A11, A21 and A31 denote the current block of JB columns*           which is about to be factorized. The number of rows in the*           partitioning are JB, I2, I3 respectively, and the numbers*           of columns are JB, J2, J3. The superdiagonal elements of A13*           and the subdiagonal elements of A31 lie outside the band.*            I2 = MIN( KL-JB, M-J-JB+1 )            I3 = MIN( JB, M-J-KL+1 )**           J2 and J3 are computed after JU has been updated.**           Factorize the current block of JB columns*            DO 80 JJ = J, J + JB - 1**              Set fill-in elements in column JJ+KV to zero*               IF( JJ+KV.LE.N ) THEN                  DO 70 I = 1, KL                     AB( I, JJ+KV ) = ZERO   70             CONTINUE               END IF**              Find pivot and test for singularity. KM is the number of*              subdiagonal elements in the current column.*               KM = MIN( KL, M-JJ )               JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 )               IPIV( JJ ) = JP + JJ - J               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )                  IF( JP.NE.1 ) THEN**                    Apply interchange to columns J to J+JB-1*                     IF( JP+JJ-1.LT.J+KL ) THEN*                        CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,     $                              AB( KV+JP+JJ-J, J ), LDAB-1 )                     ELSE**                       The interchange affects columns J to JJ-1 of A31*                       which are stored in the work array WORK31*                        CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,     $                              WORK31( JP+JJ-J-KL, 1 ), LDWORK )                        CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,     $                              AB( KV+JP, JJ ), LDAB-1 )                     END IF                  END IF**                 Compute multipliers*                  CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),     $                        1 )**                 Update trailing submatrix within the band and within*                 the current block. JM is the index of the last column*                 which needs to be updated.*                  JM = MIN( JU, J+JB-1 )                  IF( JM.GT.JJ )     $               CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,     $                          AB( KV, JJ+1 ), LDAB-1,     $                          AB( KV+1, JJ+1 ), LDAB-1 )               ELSE**                 If pivot is zero, set INFO to the index of the pivot*                 unless a zero pivot has already been found.*                  IF( INFO.EQ.0 )     $               INFO = JJ               END IF**              Copy current column of A31 into the work array WORK31*               NW = MIN( JJ-J+1, I3 )               IF( NW.GT.0 )     $            CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,     $                        WORK31( 1, JJ-J+1 ), 1 )   80       CONTINUE            IF( J+JB.LE.N ) THEN**              Apply the row interchanges to the other blocks.*               J2 = MIN( JU-J+1, KV ) - JB               J3 = MAX( 0, JU-J-KV+1 )**              Use DLASWP to apply the row interchanges to A12, A22, and*              A32.*               CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,     $                      IPIV( J ), 1 )**              Adjust the pivot indices.*               DO 90 I = J, J + JB - 1                  IPIV( I ) = IPIV( I ) + J - 1   90          CONTINUE**              Apply the row interchanges to A13, A23, and A33*              columnwise.*               K2 = J - 1 + JB + J2               DO 110 I = 1, J3                  JJ = K2 + I                  DO 100 II = J + I - 1, J + JB - 1                     IP = IPIV( II )                     IF( IP.NE.II ) THEN                        TEMP = AB( KV+1+II-JJ, JJ )                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )                        AB( KV+1+IP-JJ, JJ ) = TEMP                     END IF  100             CONTINUE  110          CONTINUE**              Update the relevant part of the trailing submatrix*               IF( J2.GT.0 ) THEN**                 Update A12*                  CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit







',     $                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,     $                        AB( KV+1-JB, J+JB ), LDAB-1 )*                  IF( I2.GT.0 ) THEN**                    Update A22*                     CALL DGEMM( 'No transpose', 'No transpose









', I2, J2,     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,     $                           AB( KV+1, J+JB ), LDAB-1 )                  END IF*                  IF( I3.GT.0 ) THEN**                    Update A32*                     CALL DGEMM( 'No transpose', 'No transpose



















', I3, J2,     $                           JB, -ONE, WORK31, LDWORK,     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,     $                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )                  END IF               END IF*               IF( J3.GT.0 ) THEN**                 Copy the lower triangle of A13 into the work array*                 WORK13*                  DO 130 JJ = 1, J3                     DO 120 II = JJ, JB                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )  120                CONTINUE  130             CONTINUE**                 Update A13 in the work array*                  CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit







',     $                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,     $                        WORK13, LDWORK )*                  IF( I2.GT.0 ) THEN**                    Update A23*                     CALL DGEMM( 'No transpose', 'No transpose









', I2, J3,     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,     $                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),     $                           LDAB-1 )                  END IF*                  IF( I3.GT.0 ) THEN**                    Update A33*                     CALL DGEMM( 'No transpose', 'No transpose


















































































', I3, J3,     $                           JB, -ONE, WORK31, LDWORK, WORK13,     $                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )                  END IF**                 Copy the lower triangle of A13 back into place*                  DO 150 JJ = 1, J3                     DO 140 II = JJ, JB                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )  140                CONTINUE  150             CONTINUE               END IF            ELSE**              Adjust the pivot indices.*               DO 160 I = J, J + JB - 1                  IPIV( I ) = IPIV( I ) + J - 1  160          CONTINUE            END IF**           Partially undo the interchanges in the current block to*           restore the upper triangular form of A31 and copy the upper*           triangle of A31 back into place*            DO 170 JJ = J + JB - 1, J, -1               JP = IPIV( JJ ) - JJ + 1               IF( JP.NE.1 ) THEN**                 Apply interchange to columns J to JJ-1*                  IF( JP+JJ-1.LT.J+KL ) THEN**                    The interchange does not affect A31*                     CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,     $                           AB( KV+JP+JJ-J, J ), LDAB-1 )                  ELSE**                    The interchange does affect A31*                     CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,     $                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )                  END IF               END IF**              Copy the current column of A31 back into place*               NW = MIN( I3, JJ-J+1 )               IF( NW.GT.0 )     $            CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1,     $                        AB( KV+KL+1-JJ+J, JJ ), 1 )  170       CONTINUE  180    CONTINUE      END IF*      RETURN**     End of DGBTRF*      END      SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,     $                   INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     March 31, 1993**     .. Scalar Arguments ..      CHARACTER          TRANS      INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS*     ..*     .. Array Arguments ..      INTEGER            IPIV( * )      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )*     ..**  Purpose*  =======**  DGBTRS solves a system of linear equations*     A * X = B  or  A' * X = B
*  with a general band matrix A using the LU factorization computed
*  by DGBTRF.
*
*  Arguments
*  =========
*
*  TRANS   (input) CHARACTER*1
*          Specifies the form of the system of equations.
*          = 'N':  A * X = B  (No transpose)
*          = 'T':  A
'* X = B  (Transpose)*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KL      (input) INTEGER
*          The number of subdiagonals within the band of A.  KL >= 0.
*
*  KU      (input) INTEGER
*          The number of superdiagonals within the band of A.  KU >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
*          Details of the LU factorization of the band matrix A, as
*          computed by DGBTRF.  U is stored as an upper triangular band
*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
*          the multipliers used during the factorization are stored in
*          rows KL+KU+2 to 2*KL+KU+1.
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices; for 1 <= i <= N, row i of the matrix was
*          interchanged with row IPIV(i).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the right hand side matrix B.
*          On exit, the solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LNOTI, NOTRAN
      INTEGER            I, J, KD, L, LM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER, DSWAP, DTBSV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBTRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
      KD = KU + KL + 1
      LNOTI = KL.GT.0
*
      IF( NOTRAN ) THEN
*
*        Solve  A*X = B.
*
*        Solve L*X = B, overwriting B with X.
*
*        L is represented as a product of permutations and unit lower
*        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
*        where each transformation L(i) is a rank-one modification of
*        the identity matrix.
*
         IF( LNOTI ) THEN
            DO 10 J = 1, N - 1
               LM = MIN( KL, N-J )
               L = IPIV( J )
               IF( L.NE.J )
     $            CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
               CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
     $                    LDB, B( J+1, 1 ), LDB )
   10       CONTINUE
         END IF
*
         DO 20 I = 1, NRHS
*
*           Solve U*X = B, overwriting B with X.
*
            CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
     $                  AB, LDAB, B( 1, I ), 1 )
   20    CONTINUE
*
      ELSE
*
*        Solve A



'*X = B.*         DO 30 I = 1, NRHS**           Solve U'*X = B, overwriting B with X.
*
            CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
     $                  LDAB, B( 1, I ), 1 )
   30    CONTINUE
*
*        Solve L




'*X = B, overwriting B with X.*         IF( LNOTI ) THEN            DO 40 J = N - 1, 1, -1               LM = MIN( KL, N-J )               CALL DGEMV( 'Transpose








































', LM, NRHS, -ONE, B( J+1, 1 ),     $                     LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )               L = IPIV( J )               IF( L.NE.J )     $            CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )   40       CONTINUE         END IF      END IF      RETURN**     End of DGBTRS*      END      SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,     $                   INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          JOB, SIDE      INTEGER            IHI, ILO, INFO, LDV, M, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   SCALE( * ), V( LDV, * )*     ..**  Purpose*  =======**  DGEBAK forms the right or left eigenvectors of a real general matrix*  by backward transformation on the computed eigenvectors of the*  balanced matrix output by DGEBAL.**  Arguments*  =========**  JOB     (input) CHARACTER*1*          Specifies the type of backward transformation required:*          = 'N
', do nothing, return immediately;*          = 'P
', do backward transformation for permutation only;*          = 'S
', do backward transformation for scaling only;*          = 'B




', do backward transformations for both permutation and*                 scaling.*          JOB must be the same as the argument JOB supplied to DGEBAL.**  SIDE    (input) CHARACTER*1*          = 'R
':  V contains right eigenvectors;*          = 'L





















































':  V contains left eigenvectors.**  N       (input) INTEGER*          The number of rows of the matrix V.  N >= 0.**  ILO     (input) INTEGER*  IHI     (input) INTEGER*          The integers ILO and IHI determined by DGEBAL.*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.**  SCALE   (input) DOUBLE PRECISION array, dimension (N)*          Details of the permutation and scaling factors, as returned*          by DGEBAL.**  M       (input) INTEGER*          The number of columns of the matrix V.  M >= 0.**  V       (input/output) DOUBLE PRECISION array, dimension (LDV,M)*          On entry, the matrix of right or left eigenvectors to be*          transformed, as returned by DHSEIN or DTREVC.*          On exit, V is overwritten by the transformed eigenvectors.**  LDV     (input) INTEGER*          The leading dimension of the array V. LDV >= max(1,N).**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE      PARAMETER          ( ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            LEFTV, RIGHTV      INTEGER            I, II, K      DOUBLE PRECISION   S*     ..*     .. External Functions ..      LOGICAL            LSAME      EXTERNAL           LSAME*     ..*     .. External Subroutines ..      EXTERNAL           DSCAL, DSWAP, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..**     Decode and Test the input parameters*      RIGHTV = LSAME( SIDE, 'R
' )      LEFTV = LSAME( SIDE, 'L


' )*      INFO = 0      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P
' ) .AND.     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B















' ) ) THEN         INFO = -1      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN         INFO = -2      ELSE IF( N.LT.0 ) THEN         INFO = -3      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN         INFO = -4      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN         INFO = -5      ELSE IF( M.LT.0 ) THEN         INFO = -7      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN         INFO = -9      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGEBAK









', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 )     $   RETURN      IF( M.EQ.0 )     $   RETURN      IF( LSAME( JOB, 'N







' ) )     $   RETURN*      IF( ILO.EQ.IHI )     $   GO TO 30**     Backward balance*      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B























' ) ) THEN*         IF( RIGHTV ) THEN            DO 10 I = ILO, IHI               S = SCALE( I )               CALL DSCAL( M, S, V( I, 1 ), LDV )   10       CONTINUE         END IF*         IF( LEFTV ) THEN            DO 20 I = ILO, IHI               S = ONE / SCALE( I )               CALL DSCAL( M, S, V( I, 1 ), LDV )   20       CONTINUE         END IF*      END IF**     Backward permutation**     For  I = ILO-1 step -1 until 1,*              IHI+1 step 1 until N do --*   30 CONTINUE      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B



































































' ) ) THEN         IF( RIGHTV ) THEN            DO 40 II = 1, N               I = II               IF( I.GE.ILO .AND. I.LE.IHI )     $            GO TO 40               IF( I.LT.ILO )     $            I = ILO - II               K = SCALE( I )               IF( K.EQ.I )     $            GO TO 40               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )   40       CONTINUE         END IF*         IF( LEFTV ) THEN            DO 50 II = 1, N               I = II               IF( I.GE.ILO .AND. I.LE.IHI )     $            GO TO 50               IF( I.LT.ILO )     $            I = ILO - II               K = SCALE( I )               IF( K.EQ.I )     $            GO TO 50               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )   50       CONTINUE         END IF      END IF*      RETURN**     End of DGEBAK*      END      SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      CHARACTER          JOB      INTEGER            IHI, ILO, INFO, LDA, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   A( LDA, * ), SCALE( * )*     ..**  Purpose*  =======**  DGEBAL balances a general real matrix A.  This involves, first,*  permuting A by a similarity transformation to isolate eigenvalues*  in the first 1 to ILO-1 and last IHI+1 to N elements on the*  diagonal; and second, applying a diagonal similarity transformation*  to rows and columns ILO to IHI to make the rows and columns as*  close in norm as possible.  Both steps are optional.**  Balancing may reduce the 1-norm of the matrix, and improve the*  accuracy of the computed eigenvalues and/or eigenvectors.**  Arguments*  =========**  JOB     (input) CHARACTER*1*          Specifies the operations to be performed on A:*          = 'N

':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0*                  for i = 1,...,N;*          = 'P
':  permute only;*          = 'S
':  scale only;*          = 'B







':  both permute and scale.**  N       (input) INTEGER*          The order of the matrix A.  N >= 0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the input matrix A.*          On exit,  A is overwritten by the balanced matrix.*          If JOB = 'N









', A is not referenced.*          See Further Details.**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,N).**  ILO     (output) INTEGER*  IHI     (output) INTEGER*          ILO and IHI are set to integers such that on exit*          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.*          If JOB = 'N' or 'S














































































', ILO = 1 and IHI = N.**  SCALE   (output) DOUBLE PRECISION array, dimension (N)*          Details of the permutations and scaling factors applied to*          A.  If P(j) is the index of the row and column interchanged*          with row and column j and D(j) is the scaling factor*          applied to row and column j, then*          SCALE(j) = P(j)    for j = 1,...,ILO-1*                   = D(j)    for j = ILO,...,IHI*                   = P(j)    for j = IHI+1,...,N.*          The order in which the interchanges are made is N to IHI+1,*          then 1 to ILO-1.**  INFO    (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  The permutations consist of row and column interchanges which put*  the matrix in the form**             ( T1   X   Y  )*     P A P = (  0   B   Z  )*             (  0   0   T2 )**  where T1 and T2 are upper triangular matrices whose eigenvalues lie*  along the diagonal.  The column indices ILO and IHI mark the starting*  and ending columns of the submatrix B. Balancing consists of applying*  a diagonal similarity transformation inv(D) * B * D to make the*  1-norms of each row of B and its corresponding column nearly equal.*  The output matrix is**     ( T1     X*D          Y    )*     (  0  inv(D)*B*D  inv(D)*Z ).*     (  0      0           T2   )**  Information about the permutations P and the diagonal matrix D is*  returned in the vector SCALE.**  This subroutine is based on the EISPACK routine BALANC.**  Modified by Tzu-Yi Chen, Computer Science Division, University of*    California at Berkeley, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, ONE      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )      DOUBLE PRECISION   SCLFAC      PARAMETER          ( SCLFAC = 0.8D+1 )      DOUBLE PRECISION   FACTOR      PARAMETER          ( FACTOR = 0.95D+0 )*     ..*     .. Local Scalars ..      LOGICAL            NOCONV      INTEGER            I, ICA, IEXC, IRA, J, K, L, M      DOUBLE PRECISION   C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,     $                   SFMIN2*     ..*     .. External Functions ..      LOGICAL            LSAME      INTEGER            IDAMAX      DOUBLE PRECISION   DLAMCH      EXTERNAL           LSAME, IDAMAX, DLAMCH*     ..*     .. External Subroutines ..      EXTERNAL           DSCAL, DSWAP, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN*     ..*     .. Executable Statements ..**     Test the input parameters*      INFO = 0      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P
' ) .AND.     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B







' ) ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN         INFO = -4      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGEBAL









', -INFO )         RETURN      END IF*      K = 1      L = N*      IF( N.EQ.0 )     $   GO TO 210*      IF( LSAME( JOB, 'N






' ) ) THEN         DO 10 I = 1, N            SCALE( I ) = ONE   10    CONTINUE         GO TO 210      END IF*      IF( LSAME( JOB, 'S




































































' ) )     $   GO TO 120**     Permutation to isolate eigenvalues if possible*      GO TO 50**     Row and column exchange.*   20 CONTINUE      SCALE( M ) = J      IF( J.EQ.M )     $   GO TO 30*      CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )      CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )*   30 CONTINUE      GO TO ( 40, 80 )IEXC**     Search for rows isolating an eigenvalue and push them down.*   40 CONTINUE      IF( L.EQ.1 )     $   GO TO 210      L = L - 1*   50 CONTINUE      DO 70 J = L, 1, -1*         DO 60 I = 1, L            IF( I.EQ.J )     $         GO TO 60            IF( A( J, I ).NE.ZERO )     $         GO TO 70   60    CONTINUE*         M = L         IEXC = 1         GO TO 20   70 CONTINUE*      GO TO 90**     Search for columns isolating an eigenvalue and push them left.*   80 CONTINUE      K = K + 1*   90 CONTINUE      DO 110 J = K, L*         DO 100 I = K, L            IF( I.EQ.J )     $         GO TO 100            IF( A( I, J ).NE.ZERO )     $         GO TO 110  100    CONTINUE*         M = K         IEXC = 2         GO TO 20  110 CONTINUE*  120 CONTINUE      DO 130 I = K, L         SCALE( I ) = ONE  130 CONTINUE*      IF( LSAME( JOB, 'P






' ) )     $   GO TO 210**     Balance the submatrix in rows K to L.**     Iterative loop for norm reduction*      SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P









































































































' )      SFMAX1 = ONE / SFMIN1      SFMIN2 = SFMIN1*SCLFAC      SFMAX2 = ONE / SFMIN2  140 CONTINUE      NOCONV = .FALSE.*      DO 200 I = K, L         C = ZERO         R = ZERO*         DO 150 J = K, L            IF( J.EQ.I )     $         GO TO 150            C = C + ABS( A( J, I ) )            R = R + ABS( A( I, J ) )  150    CONTINUE         ICA = IDAMAX( L, A( 1, I ), 1 )         CA = ABS( A( ICA, I ) )         IRA = IDAMAX( N-K+1, A( I, K ), LDA )         RA = ABS( A( I, IRA+K-1 ) )**        Guard against zero C or R due to underflow.*         IF( C.EQ.ZERO .OR. R.EQ.ZERO )     $      GO TO 200         G = R / SCLFAC         F = ONE         S = C + R  160    CONTINUE         IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.     $       MIN( R, G, RA ).LE.SFMIN2 )GO TO 170         F = F*SCLFAC         C = C*SCLFAC         CA = CA*SCLFAC         R = R / SCLFAC         G = G / SCLFAC         RA = RA / SCLFAC         GO TO 160*  170    CONTINUE         G = C / SCLFAC  180    CONTINUE         IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.     $       MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190         F = F / SCLFAC         C = C / SCLFAC         G = G / SCLFAC         CA = CA / SCLFAC         R = R*SCLFAC         RA = RA*SCLFAC         GO TO 180**        Now balance.*  190    CONTINUE         IF( ( C+R ).GE.FACTOR*S )     $      GO TO 200         IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN            IF( F*SCALE( I ).LE.SFMIN1 )     $         GO TO 200         END IF         IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN            IF( SCALE( I ).GE.SFMAX1 / F )     $         GO TO 200         END IF         G = ONE / F         SCALE( I ) = SCALE( I )*F         NOCONV = .TRUE.*         CALL DSCAL( N-K+1, G, A( I, K ), LDA )         CALL DSCAL( L, F, A( 1, I ), 1 )*  200 CONTINUE*      IF( NOCONV )     $   GO TO 140*  210 CONTINUE      ILO = K      IHI = L*      RETURN**     End of DGEBAL*      END      SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     February 29, 1992**     .. Scalar Arguments ..      INTEGER            INFO, LDA, M, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ),     $                   TAUQ( * ), WORK( * )*     ..**  Purpose*  =======**  DGEBD2 reduces a real general m by n matrix A to upper or lower*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
*
*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows in the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns in the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the m by n general matrix to be reduced.
*          On exit,
*          if m >= n, the diagonal and the first superdiagonal are
*            overwritten with the upper bidiagonal matrix B; the
*            elements below the diagonal, with the array TAUQ, represent
*            the orthogonal matrix Q as a product of elementary
*            reflectors, and the elements above the first superdiagonal,
*            with the array TAUP, represent the orthogonal matrix P as
*            a product of elementary reflectors;
*          if m < n, the diagonal and the first subdiagonal are
*            overwritten with the lower bidiagonal matrix B; the
*            elements below the first subdiagonal, with the array TAUQ,
*            represent the orthogonal matrix Q as a product of
*            elementary reflectors, and the elements above the diagonal,
*            with the array TAUP, represent the orthogonal matrix P as
*            a product of elementary reflectors.
*          See Further Details.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The diagonal elements of the bidiagonal matrix B:
*          D(i) = A(i,i).
*
*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
*          The off-diagonal elements of the bidiagonal matrix B:
*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*
*  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N))
*          The scalar factors of the elementary reflectors which
*          represent the orthogonal matrix Q. See Further Details.
*
*  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors which
*          represent the orthogonal matrix P. See Further Details.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(M,N))
*
*  INFO    (output) INTEGER
*          = 0: successful exit.
*          < 0: if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  The matrices Q and P are represented as products of elementary
*  reflectors:
*
*  If m >= n,
*
*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
*
*  Each H(i) and G(i) has the form:
*
*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
*
*  where tauq and taup are real scalars, and v and u are real vectors;
*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
*  tauq is stored in TAUQ(i) and taup in TAUP(i).
*
*  If m < n,
*
*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
*
*  Each H(i) and G(i) has the form:
*
*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
*
*  where tauq and taup are real scalars, and v and u are real vectors;
*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
*  tauq is stored in TAUQ(i) and taup in TAUP(i).
*
*  The contents of A on exit are illustrated by the following examples:
*
*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
*
*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
*    (  v1  v2  v3  v4  v5 )
*
*  where d and e denote diagonal and off-diagonal elements of B, vi
*  denotes an element of the vector defining H(i), and ui an element of
*  the vector defining G(i).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'DGEBD2', -INFO )
         RETURN
      END IF
*
      IF( M.GE.N ) THEN
*
*        Reduce to upper bidiagonal form
*
         DO 10 I = 1, N
*
*           Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
            CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
     $                   TAUQ( I ) )
            D( I ) = A( I, I )
            A( I, I ) = ONE
*
*           Apply H(i) to A(i:m,i+1:n) from the left
*
            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ),
     $                  A( I, I+1 ), LDA, WORK )
            A( I, I ) = D( I )
*
            IF( I.LT.N ) THEN
*
*              Generate elementary reflector G(i) to annihilate
*              A(i,i+2:n)
*
               CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
     $                      LDA, TAUP( I ) )
               E( I ) = A( I, I+1 )
               A( I, I+1 ) = ONE
*
*              Apply G(i) to A(i+1:m,i+1:n) from the right
*
               CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
               A( I, I+1 ) = E( I )
            ELSE
               TAUP( I ) = ZERO
            END IF
   10    CONTINUE
      ELSE
*
*        Reduce to lower bidiagonal form
*
         DO 20 I = 1, M
*
*           Generate elementary reflector G(i) to annihilate A(i,i+1:n)
*
            CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
     $                   TAUP( I ) )
            D( I ) = A( I, I )
            A( I, I ) = ONE
*
*           Apply G(i) to A(i+1:m,i:n) from the right
*
            CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ),
     $                  A( MIN( I+1, M ), I ), LDA, WORK )
            A( I, I ) = D( I )
*
            IF( I.LT.M ) THEN
*
*              Generate elementary reflector H(i) to annihilate
*              A(i+2:m,i)
*
               CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
     $                      TAUQ( I ) )
               E( I ) = A( I+1, I )
               A( I+1, I ) = ONE
*
*              Apply H(i) to A(i+1:m,i+1:n) from the left
*
               CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ),
     $                     A( I+1, I+1 ), LDA, WORK )
               A( I+1, I ) = E( I )
            ELSE
               TAUQ( I ) = ZERO
            END IF
   20    CONTINUE
      END IF
      RETURN
*
*     End of DGEBD2
*
      END
      SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
     $                   INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ),
     $                   TAUQ( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEBRD reduces a general real M-by-N matrix A to upper or lower
*  bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
*
*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows in the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns in the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N general matrix to be reduced.
*          On exit,
*          if m >= n, the diagonal and the first superdiagonal are
*            overwritten with the upper bidiagonal matrix B; the
*            elements below the diagonal, with the array TAUQ, represent
*            the orthogonal matrix Q as a product of elementary
*            reflectors, and the elements above the first superdiagonal,
*            with the array TAUP, represent the orthogonal matrix P as
*            a product of elementary reflectors;
*          if m < n, the diagonal and the first subdiagonal are
*            overwritten with the lower bidiagonal matrix B; the
*            elements below the first subdiagonal, with the array TAUQ,
*            represent the orthogonal matrix Q as a product of
*            elementary reflectors, and the elements above the diagonal,
*            with the array TAUP, represent the orthogonal matrix P as
*            a product of elementary reflectors.
*          See Further Details.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The diagonal elements of the bidiagonal matrix B:
*          D(i) = A(i,i).
*
*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
*          The off-diagonal elements of the bidiagonal matrix B:
*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*
*  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N))
*          The scalar factors of the elementary reflectors which
*          represent the orthogonal matrix Q. See Further Details.
*
*  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors which
*          represent the orthogonal matrix P. See Further Details.
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The length of the array WORK.  LWORK >= max(1,M,N).
*          For optimum performance LWORK >= (M+N)*NB, where NB
*          is the optimal blocksize.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  The matrices Q and P are represented as products of elementary
*  reflectors:
*
*  If m >= n,
*
*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
*
*  Each H(i) and G(i) has the form:
*
*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
*
*  where tauq and taup are real scalars, and v and u are real vectors;
*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
*  tauq is stored in TAUQ(i) and taup in TAUP(i).
*
*  If m < n,
*
*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
*
*  Each H(i) and G(i) has the form:
*
*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
*
*  where tauq and taup are real scalars, and v and u are real vectors;
*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
*  tauq is stored in TAUQ(i) and taup in TAUP(i).
*
*  The contents of A on exit are illustrated by the following examples:
*
*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
*
*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
*    (  v1  v2  v3  v4  v5 )
*
*  where d and e denote diagonal and off-diagonal elements of B, vi
*  denotes an element of the vector defining H(i), and ui an element of
*  the vector defining G(i).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
     $                   NBMIN, NX
      DOUBLE PRECISION   WS
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEBD2, DGEMM, DLABRD, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
      LWKOPT = ( M+N )*NB
      WORK( 1 ) = DBLE( LWKOPT )
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -10
      END IF
      IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'DGEBRD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      MINMN = MIN( M, N )
      IF( MINMN.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
      WS = MAX( M, N )
      LDWRKX = M
      LDWRKY = N
*
      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
*
*        Set the crossover point NX.
*
         NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) )
*
*        Determine when to switch from blocked to unblocked code.
*
         IF( NX.LT.MINMN ) THEN
            WS = ( M+N )*NB
            IF( LWORK.LT.WS ) THEN
*
*              Not enough work space for the optimal NB, consider using
*              a smaller block size.
*
               NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 )
               IF( LWORK.GE.( M+N )*NBMIN ) THEN
                  NB = LWORK / ( M+N )
               ELSE
                  NB = 1
                  NX = MINMN
               END IF
            END IF
         END IF
      ELSE
         NX = MINMN
      END IF
*
      DO 30 I = 1, MINMN - NX, NB
*
*        Reduce rows and columns i:i+nb-1 to bidiagonal form and return
*        the matrices X and Y which are needed to update the unreduced
*        part of the matrix
*
         CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
     $                TAUQ( I ), TAUP( I ), WORK, LDWRKX,
     $                WORK( LDWRKX*NB+1 ), LDWRKY )
*
*        Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
*        of the form  A := A - V*Y' - X*U'
*
         CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1,
     $               NB, -ONE, A( I+NB, I ), LDA,
     $               WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
     $               A( I+NB, I+NB ), LDA )
         CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
     $               NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
     $               ONE, A( I+NB, I+NB ), LDA )
*
*        Copy diagonal and off-diagonal elements of B back into A
*
         IF( M.GE.N ) THEN
            DO 10 J = I, I + NB - 1
               A( J, J ) = D( J )
               A( J, J+1 ) = E( J )
   10       CONTINUE
         ELSE
            DO 20 J = I, I + NB - 1
               A( J, J ) = D( J )
               A( J+1, J ) = E( J )
   20       CONTINUE
         END IF
   30 CONTINUE
*
*     Use unblocked code to reduce the remainder of the matrix
*
      CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
     $             TAUQ( I ), TAUP( I ), WORK, IINFO )
      WORK( 1 ) = WS
      RETURN
*
*     End of DGEBRD
*
      END
      SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK,
     $                   INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   ANORM, RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGECON estimates the reciprocal of the condition number of a general
*  real matrix A, in either the 1-norm or the infinity-norm, using
*  the LU factorization computed by DGETRF.
*
*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
*  condition number is computed as
*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*
*  Arguments
*  =========
*
*  NORM    (input) CHARACTER*1
*          Specifies whether the 1-norm condition number or the
*          infinity-norm condition number is required:
*          = '1' or 'O':  1-norm;
*          = 'I':         Infinity-norm.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The factors L and U from the factorization A = P*L*U
*          as computed by DGETRF.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  ANORM   (input) DOUBLE PRECISION
*          If NORM = '1' or 'O', the 1-norm of the original matrix A.
*          If NORM = 'I', the infinity-norm of the original matrix A.
*
*  RCOND   (output) DOUBLE PRECISION
*          The reciprocal of the condition number of the matrix A,
*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
*
*  IWORK   (workspace) INTEGER array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ONENRM
      CHARACTER          NORMIN
      INTEGER            IX, KASE, KASE1
      DOUBLE PRECISION   AINVNM, SCALE, SL, SMLNUM, SU
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, IDAMAX, DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLACON, DLATRS, DRSCL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGECON', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
*
      SMLNUM = DLAMCH( 'Safe minimum' )
*
*     Estimate the norm of inv(A).
*
      AINVNM = ZERO
      NORMIN = 'N'
      IF( ONENRM ) THEN
         KASE1 = 1
      ELSE
         KASE1 = 2
      END IF
      KASE = 0
   10 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
         IF( KASE.EQ.KASE1 ) THEN
*
*           Multiply by inv(L).
*
            CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
     $                   LDA, WORK, SL, WORK( 2*N+1 ), INFO )
*
*           Multiply by inv(U).
*
            CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
     $                   A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
         ELSE
*
*           Multiply by inv(U

').*            CALL DLATRS( 'Upper', 'Transpose', 'Non-unit


', NORMIN, N, A,     $                   LDA, WORK, SU, WORK( 3*N+1 ), INFO )**           Multiply by inv(L').
*
            CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A,
     $                   LDA, WORK, SL, WORK( 2*N+1 ), INFO )
         END IF
*
*        Divide X by 1/(SL*SU) if doing so will not cause overflow.
*
         SCALE = SL*SU
         NORMIN = 'Y'
         IF( SCALE.NE.ONE ) THEN
            IX = IDAMAX( N, WORK, 1 )
            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
     $         GO TO 20
            CALL DRSCL( N, SCALE, WORK, 1 )
         END IF
         GO TO 10
      END IF
*
*     Compute the estimate of the reciprocal condition number.
*
      IF( AINVNM.NE.ZERO )
     $   RCOND = ( ONE / AINVNM ) / ANORM
*
   20 CONTINUE
      RETURN
*
*     End of DGECON
*
      END
      SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
     $                   INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
      DOUBLE PRECISION   AMAX, COLCND, ROWCND
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( * ), R( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEEQU computes row and column scalings intended to equilibrate an
*  M-by-N matrix A and reduce its condition number.  R returns the row
*  scale factors and C the column scale factors, chosen to try to make
*  the largest element in each row and column of the matrix B with
*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*
*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
*  number and BIGNUM = largest safe number.  Use of these scaling
*  factors is not guaranteed to reduce the condition number of A but
*  works well in practice.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The M-by-N matrix whose equilibration factors are
*          to be computed.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  R       (output) DOUBLE PRECISION array, dimension (M)
*          If INFO = 0 or INFO > M, R contains the row scale factors
*          for A.
*
*  C       (output) DOUBLE PRECISION array, dimension (N)
*          If INFO = 0,  C contains the column scale factors for A.
*
*  ROWCND  (output) DOUBLE PRECISION
*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
*          AMAX is neither too large nor too small, it is not worth
*          scaling by R.
*
*  COLCND  (output) DOUBLE PRECISION
*          If INFO = 0, COLCND contains the ratio of the smallest
*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
*          worth scaling by C.
*
*  AMAX    (output) DOUBLE PRECISION
*          Absolute value of largest matrix element.  If AMAX is very
*          close to overflow or very close to underflow, the matrix
*          should be scaled.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i,  and i is
*                <= M:  the i-th row of A is exactly zero
*                >  M:  the (i-M)-th column of A is exactly zero
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEEQU', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         ROWCND = ONE
         COLCND = ONE
         AMAX = ZERO
         RETURN
      END IF
*
*     Get machine constants.
*
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
*
*     Compute row scale factors.
*
      DO 10 I = 1, M
         R( I ) = ZERO
   10 CONTINUE
*
*     Find the maximum element in each row.
*
      DO 30 J = 1, N
         DO 20 I = 1, M
            R( I ) = MAX( R( I ), ABS( A( I, J ) ) )
   20    CONTINUE
   30 CONTINUE
*
*     Find the maximum and minimum scale factors.
*
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO 40 I = 1, M
         RCMAX = MAX( RCMAX, R( I ) )
         RCMIN = MIN( RCMIN, R( I ) )
   40 CONTINUE
      AMAX = RCMAX
*
      IF( RCMIN.EQ.ZERO ) THEN
*
*        Find the first zero scale factor and return an error code.
*
         DO 50 I = 1, M
            IF( R( I ).EQ.ZERO ) THEN
               INFO = I
               RETURN
            END IF
   50    CONTINUE
      ELSE
*
*        Invert the scale factors.
*
         DO 60 I = 1, M
            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
   60    CONTINUE
*
*        Compute ROWCND = min(R(I)) / max(R(I))
*
         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
      END IF
*
*     Compute column scale factors
*
      DO 70 J = 1, N
         C( J ) = ZERO
   70 CONTINUE
*
*     Find the maximum element in each column,
*     assuming the row scaling computed above.
*
      DO 90 J = 1, N
         DO 80 I = 1, M
            C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) )
   80    CONTINUE
   90 CONTINUE
*
*     Find the maximum and minimum scale factors.
*
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO 100 J = 1, N
         RCMIN = MIN( RCMIN, C( J ) )
         RCMAX = MAX( RCMAX, C( J ) )
  100 CONTINUE
*
      IF( RCMIN.EQ.ZERO ) THEN
*
*        Find the first zero scale factor and return an error code.
*
         DO 110 J = 1, N
            IF( C( J ).EQ.ZERO ) THEN
               INFO = M + J
               RETURN
            END IF
  110    CONTINUE
      ELSE
*
*        Invert the scale factors.
*
         DO 120 J = 1, N
            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
  120    CONTINUE
*
*        Compute COLCND = min(C(J)) / max(C(J))
*
         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
      END IF
*
      RETURN
*
*     End of DGEEQU
*
      END
      SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      INTEGER            IHI, ILO, INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
*  an orthogonal similarity transformation:  Q














































' * A * Q = H .**  Arguments*  =========**  N       (input) INTEGER*          The order of the matrix A.  N >= 0.**  ILO     (input) INTEGER*  IHI     (input) INTEGER*          It is assumed that A is already upper triangular in rows*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally*          set by a previous call to DGEBAL; otherwise they should be*          set to 1 and N respectively. See Further Details.*          1 <= ILO <= IHI <= max(1,N).**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the n by n general matrix to be reduced.*          On exit, the upper triangle and the first subdiagonal of A*          are overwritten with the upper Hessenberg matrix H, and the*          elements below the first subdiagonal, with the array TAU,*          represent the orthogonal matrix Q as a product of elementary*          reflectors. See Further Details.**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,N).**  TAU     (output) DOUBLE PRECISION array, dimension (N-1)*          The scalar factors of the elementary reflectors (see Further*          Details).**  WORK    (workspace) DOUBLE PRECISION array, dimension (N)**  INFO    (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  The matrix Q is represented as a product of (ihi-ilo) elementary*  reflectors**     Q = H(ilo) H(ilo+1) . . . H(ihi-1).**  Each H(i) has the form**     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
*  exit in A(i+2:ihi,i), and tau in TAU(i).
*
*  The contents of A are illustrated by the following example, with
*  n = 7, ilo = 2 and ihi = 6:
*
*  on entry,                        on exit,
*
*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
*  (                         a )    (                          a )
*
*  where a denotes an element of the original matrix A, h denotes a
*  modified element of the upper Hessenberg matrix H, and vi denotes an
*  element of the vector defining H(i).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   AII
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEHD2', -INFO )
         RETURN
      END IF
*
      DO 10 I = ILO, IHI - 1
*
*        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*
         CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
     $                TAU( I ) )
         AII = A( I+1, I )
         A( I+1, I ) = ONE
*
*        Apply H(i) to A(1:ihi,i+1:ihi) from the right
*
         CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
     $               A( 1, I+1 ), LDA, WORK )
*
*        Apply H(i) to A(i+1:ihi,i+1:n) from the left
*
         CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
     $               A( I+1, I+1 ), LDA, WORK )
*
         A( I+1, I ) = AII
   10 CONTINUE
*
      RETURN
*
*     End of DGEHD2
*
      END
      SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEHRD reduces a real general matrix A to upper Hessenberg form H by
*  an orthogonal similarity transformation:  Q


























































' * A * Q = H .**  Arguments*  =========**  N       (input) INTEGER*          The order of the matrix A.  N >= 0.**  ILO     (input) INTEGER*  IHI     (input) INTEGER*          It is assumed that A is already upper triangular in rows*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally*          set by a previous call to DGEBAL; otherwise they should be*          set to 1 and N respectively. See Further Details.*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the N-by-N general matrix to be reduced.*          On exit, the upper triangle and the first subdiagonal of A*          are overwritten with the upper Hessenberg matrix H, and the*          elements below the first subdiagonal, with the array TAU,*          represent the orthogonal matrix Q as a product of elementary*          reflectors. See Further Details.**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,N).**  TAU     (output) DOUBLE PRECISION array, dimension (N-1)*          The scalar factors of the elementary reflectors (see Further*          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to*          zero.**  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.**  LWORK   (input) INTEGER*          The length of the array WORK.  LWORK >= max(1,N).*          For optimum performance LWORK >= N*NB, where NB is the*          optimal blocksize.**          If LWORK = -1, then a workspace query is assumed; the routine*          only calculates the optimal size of the WORK array, returns*          this value as the first entry of the WORK array, and no error*          message related to LWORK is issued by XERBLA.**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  The matrix Q is represented as a product of (ihi-ilo) elementary*  reflectors**     Q = H(ilo) H(ilo+1) . . . H(ihi-1).**  Each H(i) has the form**     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
*  exit in A(i+2:ihi,i), and tau in TAU(i).
*
*  The contents of A are illustrated by the following example, with
*  n = 7, ilo = 2 and ihi = 6:
*
*  on entry,                        on exit,
*
*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
*  (                         a )    (                          a )
*
*  where a denotes an element of the original matrix A, h denotes a
*  modified element of the upper Hessenberg matrix H, and vi denotes an
*  element of the vector defining H(i).
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN,
     $                   NH, NX
      DOUBLE PRECISION   EI
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   T( LDT, NBMAX )
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEHD2, DGEMM, DLAHRD, DLARFB, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEHRD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
*
      DO 10 I = 1, ILO - 1
         TAU( I ) = ZERO
   10 CONTINUE
      DO 20 I = MAX( 1, IHI ), N - 1
         TAU( I ) = ZERO
   20 CONTINUE
*
*     Quick return if possible
*
      NH = IHI - ILO + 1
      IF( NH.LE.1 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
*     Determine the block size.
*
      NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
      NBMIN = 2
      IWS = 1
      IF( NB.GT.1 .AND. NB.LT.NH ) THEN
*
*        Determine when to cross over from blocked to unblocked code
*        (last block is always handled by unblocked code).
*
         NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
         IF( NX.LT.NH ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            IWS = N*NB
            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  determine the
*              minimum value of NB, and reduce NB or force use of
*              unblocked code.
*
               NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI,
     $                 -1 ) )
               IF( LWORK.GE.N*NBMIN ) THEN
                  NB = LWORK / N
               ELSE
                  NB = 1
               END IF
            END IF
         END IF
      END IF
      LDWORK = N
*
      IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
*
*        Use unblocked code below
*
         I = ILO
*
      ELSE
*
*        Use blocked code
*
         DO 30 I = ILO, IHI - 1 - NX, NB
            IB = MIN( NB, IHI-I )
*
*           Reduce columns i:i+ib-1 to Hessenberg form, returning the
*           matrices V and T of the block reflector H = I - V*T*V






'*           which performs the reduction, and also the matrix Y = A*V*T*            CALL DLAHRD( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT,     $                   WORK, LDWORK )**           Apply the block reflector H to A(1:ihi,i+ib:ihi) from the*           right, computing  A := A - Y * V'. V(i+ib,ib-1) must be set
*           to 1.
*
            EI = A( I+IB, I+IB-1 )
            A( I+IB, I+IB-1 ) = ONE
            CALL DGEMM( 'No transpose', 'Transpose', IHI, IHI-I-IB+1,
     $                  IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
     $                  A( 1, I+IB ), LDA )
            A( I+IB, I+IB-1 ) = EI
*
*           Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
*           left
*
            CALL DLARFB( 'Left', 'Transpose', 'Forward', 'Columnwise',
     $                   IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT,
     $                   A( I+1, I+IB ), LDA, WORK, LDWORK )
   30    CONTINUE
      END IF
*
*     Use unblocked code to reduce the rest of the matrix
*
      CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
      WORK( 1 ) = IWS
*
      RETURN
*
*     End of DGEHRD
*
      END
      SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGELQ2 computes an LQ factorization of a real m by n matrix A:
*  A = L * Q.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the m by n matrix A.
*          On exit, the elements on and below the diagonal of the array
*          contain the m by min(m,n) lower trapezoidal matrix L (L is
*          lower triangular if m <= n); the elements above the diagonal,
*          with the array TAU, represent the orthogonal matrix Q as a
*          product of elementary reflectors (see Further Details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors (see Further
*          Details).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(k) . . . H(2) H(1), where k = min(m,n).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v


































'**  where tau is a real scalar, and v is a real vector with*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),*  and tau in TAU(i).**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE      PARAMETER          ( ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      INTEGER            I, K      DOUBLE PRECISION   AII*     ..*     .. External Subroutines ..      EXTERNAL           DLARF, DLARFG, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..**     Test the input arguments*      INFO = 0      IF( M.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN         INFO = -4      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGELQ2

















', -INFO )         RETURN      END IF*      K = MIN( M, N )*      DO 10 I = 1, K**        Generate elementary reflector H(i) to annihilate A(i,i+1:n)*         CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,     $                TAU( I ) )         IF( I.LT.M ) THEN**           Apply H(i) to A(i+1:m,i:n) from the right*            AII = A( I, I )            A( I, I ) = ONE            CALL DLARF( 'Right















































































', M-I, N-I+1, A( I, I ), LDA, TAU( I ),     $                  A( I+1, I ), LDA, WORK )            A( I, I ) = AII         END IF   10 CONTINUE      RETURN**     End of DGELQ2*      END      SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            INFO, LDA, LWORK, M, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )*     ..**  Purpose*  =======**  DGELQF computes an LQ factorization of a real M-by-N matrix A:*  A = L * Q.**  Arguments*  =========**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the M-by-N matrix A.*          On exit, the elements on and below the diagonal of the array*          contain the m-by-min(m,n) lower trapezoidal matrix L (L is*          lower triangular if m <= n); the elements above the diagonal,*          with the array TAU, represent the orthogonal matrix Q as a*          product of elementary reflectors (see Further Details).**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,M).**  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))*          The scalar factors of the elementary reflectors (see Further*          Details).**  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.**  LWORK   (input) INTEGER*          The dimension of the array WORK.  LWORK >= max(1,M).*          For optimum performance LWORK >= M*NB, where NB is the*          optimal blocksize.**          If LWORK = -1, then a workspace query is assumed; the routine*          only calculates the optimal size of the WORK array, returns*          this value as the first entry of the WORK array, and no error*          message related to LWORK is issued by XERBLA.**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value**  Further Details*  ===============**  The matrix Q is represented as a product of elementary reflectors**     Q = H(k) . . . H(2) H(1), where k = min(m,n).**  Each H(i) has the form**     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
*  and tau in TAU(i).
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
     $                   NBMIN, NX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGELQ2, DLARFB, DLARFT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
      LWKOPT = M*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELQF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
      NBMIN = 2
      NX = 0
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
*        Determine when to cross over from blocked to unblocked code.
*
         NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  reduce NB and
*              determine the minimum value of NB.
*
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
*
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
*        Use blocked code initially
*
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
*
*           Compute the LQ factorization of the current block
*           A(i:i+ib-1,i:n)
*
            CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
            IF( I+IB.LE.M ) THEN
*
*              Form the triangular factor of the block reflector
*              H = H(i) H(i+1) . . . H(i+ib-1)
*
               CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
     $                      LDA, TAU( I ), WORK, LDWORK )
*
*              Apply H to A(i+ib:m,i:n) from the right
*
               CALL DLARFB( 'Right', 'No transpose', 'Forward',
     $                      'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
     $                      LDA, WORK, LDWORK, A( I+IB, I ), LDA,
     $                      WORK( IB+1 ), LDWORK )
            END IF
   10    CONTINUE
      ELSE
         I = 1
      END IF
*
*     Use unblocked code to factor the last or only block.
*
      IF( I.LE.K )
     $   CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                IINFO )
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGELQF
*
      END
      SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEQL2 computes a QL factorization of a real m by n matrix A:
*  A = Q * L.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the m by n matrix A.
*          On exit, if m >= n, the lower triangle of the subarray
*          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
*          if m <= n, the elements on and below the (n-m)-th
*          superdiagonal contain the m by n lower trapezoidal matrix L;
*          the remaining elements, with the array TAU, represent the
*          orthogonal matrix Q as a product of elementary reflectors
*          (see Further Details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors (see Further
*          Details).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(k) . . . H(2) H(1), where k = min(m,n).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v


































'**  where tau is a real scalar, and v is a real vector with*  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in*  A(1:m-k+i-1,n-k+i), and tau in TAU(i).**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE      PARAMETER          ( ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      INTEGER            I, K      DOUBLE PRECISION   AII*     ..*     .. External Subroutines ..      EXTERNAL           DLARF, DLARFG, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..**     Test the input arguments*      INFO = 0      IF( M.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN         INFO = -4      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGEQL2

















', -INFO )         RETURN      END IF*      K = MIN( M, N )*      DO 10 I = K, 1, -1**        Generate elementary reflector H(i) to annihilate*        A(1:m-k+i-1,n-k+i)*         CALL DLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1,     $                TAU( I ) )**        Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left*         AII = A( M-K+I, N-K+I )         A( M-K+I, N-K+I ) = ONE         CALL DLARF( 'Left

















































































', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ),     $               A, LDA, WORK )         A( M-K+I, N-K+I ) = AII   10 CONTINUE      RETURN**     End of DGEQL2*      END      SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            INFO, LDA, LWORK, M, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )*     ..**  Purpose*  =======**  DGEQLF computes a QL factorization of a real M-by-N matrix A:*  A = Q * L.**  Arguments*  =========**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the M-by-N matrix A.*          On exit,*          if m >= n, the lower triangle of the subarray*          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;*          if m <= n, the elements on and below the (n-m)-th*          superdiagonal contain the M-by-N lower trapezoidal matrix L;*          the remaining elements, with the array TAU, represent the*          orthogonal matrix Q as a product of elementary reflectors*          (see Further Details).**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,M).**  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))*          The scalar factors of the elementary reflectors (see Further*          Details).**  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.**  LWORK   (input) INTEGER*          The dimension of the array WORK.  LWORK >= max(1,N).*          For optimum performance LWORK >= N*NB, where NB is the*          optimal blocksize.**          If LWORK = -1, then a workspace query is assumed; the routine*          only calculates the optimal size of the WORK array, returns*          this value as the first entry of the WORK array, and no error*          message related to LWORK is issued by XERBLA.**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value**  Further Details*  ===============**  The matrix Q is represented as a product of elementary reflectors**     Q = H(k) . . . H(2) H(1), where k = min(m,n).**  Each H(i) has the form**     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
*  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
     $                   MU, NB, NBMIN, NU, NX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEQL2, DLARFB, DLARFT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      NB = ILAENV( 1, 'DGEQLF', ' ', M, N, -1, -1 )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQLF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
      NBMIN = 2
      NX = 1
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
*        Determine when to cross over from blocked to unblocked code.
*
         NX = MAX( 0, ILAENV( 3, 'DGEQLF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  reduce NB and
*              determine the minimum value of NB.
*
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGEQLF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
*
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
*        Use blocked code initially.
*        The last kk columns are handled by the block method.
*
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
*
         DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
            IB = MIN( K-I+1, NB )
*
*           Compute the QL factorization of the current block
*           A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
*
            CALL DGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ),
     $                   WORK, IINFO )
            IF( N-K+I.GT.1 ) THEN
*
*              Form the triangular factor of the block reflector
*              H = H(i+ib-1) . . . H(i+1) H(i)
*
               CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
     $                      A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
*
*              Apply H

' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left*               CALL DLARFB( 'Left', 'Transpose', 'Backward
',     $                      'Columnwise



































































































', M-K+I+IB-1, N-K+I-1, IB,     $                      A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,     $                      WORK( IB+1 ), LDWORK )            END IF   10    CONTINUE         MU = M - K + I + NB - 1         NU = N - K + I + NB - 1      ELSE         MU = M         NU = N      END IF**     Use unblocked code to factor the last or only block*      IF( MU.GT.0 .AND. NU.GT.0 )     $   CALL DGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )*      WORK( 1 ) = IWS      RETURN**     End of DGEQLF*      END      SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            INFO, LDA, LWORK, M, N*     ..*     .. Array Arguments ..      INTEGER            JPVT( * )      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )*     ..**  Purpose*  =======**  DGEQP3 computes a QR factorization with column pivoting of a*  matrix A:  A*P = Q*R  using Level 3 BLAS.**  Arguments*  =========**  M       (input) INTEGER*          The number of rows of the matrix A. M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the M-by-N matrix A.*          On exit, the upper triangle of the array contains the*          min(M,N)-by-N upper trapezoidal matrix R; the elements below*          the diagonal, together with the array TAU, represent the*          orthogonal matrix Q as a product of min(M,N) elementary*          reflectors.**  LDA     (input) INTEGER*          The leading dimension of the array A. LDA >= max(1,M).**  JPVT    (input/output) INTEGER array, dimension (N)*          On entry, if JPVT(J).ne.0, the J-th column of A is permuted*          to the front of A*P (a leading column); if JPVT(J)=0,*          the J-th column of A is a free column.*          On exit, if JPVT(J)=K, then the J-th column of A*P was the*          the K-th column of A.**  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))*          The scalar factors of the elementary reflectors.**  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)*          On exit, if INFO=0, WORK(1) returns the optimal LWORK.**  LWORK   (input) INTEGER*          The dimension of the array WORK. LWORK >= 3*N+1.*          For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB*          is the optimal blocksize.**          If LWORK = -1, then a workspace query is assumed; the routine*          only calculates the optimal size of the WORK array, returns*          this value as the first entry of the WORK array, and no error*          message related to LWORK is issued by XERBLA.**  INFO    (output) INTEGER*          = 0: successful exit.*          < 0: if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  The matrix Q is represented as a product of elementary reflectors**     Q = H(1) H(2) . . . H(k), where k = min(m,n).**  Each H(i) has the form**     H(i) = I - tau * v * v'
*
*  where tau is a real/complex scalar, and v is a real/complex vector
*  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
*  A(i+1:m,i), and tau in TAU(i).
*
*  Based on contributions by
*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*    X. Sun, Computer Science Dept., Duke University, USA
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            INB, INBMIN, IXOVER
      PARAMETER          ( INB = 1, INBMIN = 2, IXOVER = 3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
     $                   NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DNRM2
      EXTERNAL           ILAENV, DNRM2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      IWS = 3*N + 1
      MINMN = MIN( M, N )
*
*     Test input arguments
*     ====================
*
      INFO = 0
      NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 )
      LWKOPT = 2*N + ( N+1 )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQP3', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( MINMN.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
*     Move initial columns up front.
*
      NFXD = 1
      DO 10 J = 1, N
         IF( JPVT( J ).NE.0 ) THEN
            IF( J.NE.NFXD ) THEN
               CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 )
               JPVT( J ) = JPVT( NFXD )
               JPVT( NFXD ) = J
            ELSE
               JPVT( J ) = J
            END IF
            NFXD = NFXD + 1
         ELSE
            JPVT( J ) = J
         END IF
   10 CONTINUE
      NFXD = NFXD - 1
*
*     Factorize fixed columns
*     =======================
*
*     Compute the QR factorization of fixed columns and update
*     remaining columns.
*
      IF( NFXD.GT.0 ) THEN
         NA = MIN( M, NFXD )
*CC      CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
         CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
         IWS = MAX( IWS, INT( WORK( 1 ) ) )
         IF( NA.LT.N ) THEN
*CC         CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
*CC  $                   TAU, A( 1, NA+1 ), LDA, WORK, INFO )
            CALL DORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU,
     $                   A( 1, NA+1 ), LDA, WORK, LWORK, INFO )
            IWS = MAX( IWS, INT( WORK( 1 ) ) )
         END IF
      END IF
*
*     Factorize free columns
*     ======================
*
      IF( NFXD.LT.MINMN ) THEN
*
         SM = M - NFXD
         SN = N - NFXD
         SMINMN = MINMN - NFXD
*
*        Determine the block size.
*
         NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 )
         NBMIN = 2
         NX = 0
*
         IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN
*
*           Determine when to cross over from blocked to unblocked code.
*
            NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1,
     $           -1 ) )
*
*
            IF( NX.LT.SMINMN ) THEN
*
*              Determine if workspace is large enough for blocked code.
*
               MINWS = 2*SN + ( SN+1 )*NB
               IWS = MAX( IWS, MINWS )
               IF( LWORK.LT.MINWS ) THEN
*
*                 Not enough workspace to use optimal NB: Reduce NB and
*                 determine the minimum value of NB.
*
                  NB = ( LWORK-2*SN ) / ( SN+1 )
                  NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, SN,
     $                    -1, -1 ) )
*
*
               END IF
            END IF
         END IF
*
*        Initialize partial column norms. The first N elements of work
*        store the exact column norms.
*
         DO 20 J = NFXD + 1, N
            WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 )
            WORK( N+J ) = WORK( J )
   20    CONTINUE
*
         IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND.
     $       ( NX.LT.SMINMN ) ) THEN
*
*           Use blocked code initially.
*
            J = NFXD + 1
*
*           Compute factorization: while loop.
*
*
            TOPBMN = MINMN - NX
   30       CONTINUE
            IF( J.LE.TOPBMN ) THEN
               JB = MIN( NB, TOPBMN-J+1 )
*
*              Factorize JB columns among columns J:N.
*
               CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA,
     $                      JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ),
     $                      WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 )
*
               J = J + FJB
               GO TO 30
            END IF
         ELSE
            J = NFXD + 1
         END IF
*
*        Use unblocked code to factor the last or only block.
*
*
         IF( J.LE.MINMN )
     $      CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ),
     $                   TAU( J ), WORK( J ), WORK( N+J ),
     $                   WORK( 2*N+1 ) )
*
      END IF
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGEQP3
*
      END
      SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
*
*  -- LAPACK test routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  This routine is deprecated and has been replaced by routine DGEQP3.
*
*  DGEQPF computes a QR factorization with column pivoting of a
*  real M-by-N matrix A: A*P = Q*R.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A. N >= 0
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit, the upper triangle of the array contains the
*          min(M,N)-by-N upper triangular matrix R; the elements
*          below the diagonal, together with the array TAU,
*          represent the orthogonal matrix Q as a product of
*          min(m,n) elementary reflectors.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,M).
*
*  JPVT    (input/output) INTEGER array, dimension (N)
*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
*          to the front of A*P (a leading column); if JPVT(i) = 0,
*          the i-th column of A is a free column.
*          On exit, if JPVT(i) = k, then the i-th column of A*P
*          was the k-th column of A.
*
*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(1) H(2) . . . H(n)
*
*  Each H(i) has the form
*
*     H = I - tau * v * v










































'**  where tau is a real scalar, and v is a real vector with*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).**  The matrix P is represented in jpvt as follows: If*     jpvt(j) = i*  then the jth column of P is the ith canonical unit vector.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, ONE      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      INTEGER            I, ITEMP, J, MA, MN, PVT      DOUBLE PRECISION   AII, TEMP, TEMP2*     ..*     .. External Subroutines ..      EXTERNAL           DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN, SQRT*     ..*     .. External Functions ..      INTEGER            IDAMAX      DOUBLE PRECISION   DNRM2      EXTERNAL           IDAMAX, DNRM2*     ..*     .. Executable Statements ..**     Test the input arguments*      INFO = 0      IF( M.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN         INFO = -4      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGEQPF






























', -INFO )         RETURN      END IF*      MN = MIN( M, N )**     Move initial columns up front*      ITEMP = 1      DO 10 I = 1, N         IF( JPVT( I ).NE.0 ) THEN            IF( I.NE.ITEMP ) THEN               CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )               JPVT( I ) = JPVT( ITEMP )               JPVT( ITEMP ) = I            ELSE               JPVT( I ) = I            END IF            ITEMP = ITEMP + 1         ELSE            JPVT( I ) = I         END IF   10 CONTINUE      ITEMP = ITEMP - 1**     Compute the QR factorization and update remaining columns*      IF( ITEMP.GT.0 ) THEN         MA = MIN( ITEMP, M )         CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO )         IF( MA.LT.N ) THEN            CALL DORM2R( 'Left', 'Transpose













































', M, N-MA, MA, A, LDA, TAU,     $                   A( 1, MA+1 ), LDA, WORK, INFO )         END IF      END IF*      IF( ITEMP.LT.MN ) THEN**        Initialize partial column norms. The first n elements of*        work store the exact column norms.*         DO 20 I = ITEMP + 1, N            WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )            WORK( N+I ) = WORK( I )   20    CONTINUE**        Compute factorization*         DO 40 I = ITEMP + 1, MN**           Determine ith pivot column and swap if necessary*            PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 )*            IF( PVT.NE.I ) THEN               CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )               ITEMP = JPVT( PVT )               JPVT( PVT ) = JPVT( I )               JPVT( I ) = ITEMP               WORK( PVT ) = WORK( I )               WORK( N+PVT ) = WORK( N+I )            END IF**           Generate elementary reflector H(i)*            IF( I.LT.M ) THEN               CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )            ELSE               CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )            END IF*            IF( I.LT.N ) THEN**              Apply H(i) to A(i:m,i+1:n) from the left*               AII = A( I, I )               A( I, I ) = ONE               CALL DLARF( 'LEFT




























































































', M-I+1, N-I, A( I, I ), 1, TAU( I ),     $                     A( I, I+1 ), LDA, WORK( 2*N+1 ) )               A( I, I ) = AII            END IF**           Update partial column norms*            DO 30 J = I + 1, N               IF( WORK( J ).NE.ZERO ) THEN                  TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2                  TEMP = MAX( TEMP, ZERO )                  TEMP2 = ONE + 0.05D0*TEMP*     $                    ( WORK( J ) / WORK( N+J ) )**2                  IF( TEMP2.EQ.ONE ) THEN                     IF( M-I.GT.0 ) THEN                        WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 )                        WORK( N+J ) = WORK( J )                     ELSE                        WORK( J ) = ZERO                        WORK( N+J ) = ZERO                     END IF                  ELSE                     WORK( J ) = WORK( J )*SQRT( TEMP )                  END IF               END IF   30       CONTINUE*   40    CONTINUE      END IF      RETURN**     End of DGEQPF*      END      SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     February 29, 1992**     .. Scalar Arguments ..      INTEGER            INFO, LDA, M, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )*     ..**  Purpose*  =======**  DGEQR2 computes a QR factorization of a real m by n matrix A:*  A = Q * R.**  Arguments*  =========**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the m by n matrix A.*          On exit, the elements on and above the diagonal of the array*          contain the min(m,n) by n upper trapezoidal matrix R (R is*          upper triangular if m >= n); the elements below the diagonal,*          with the array TAU, represent the orthogonal matrix Q as a*          product of elementary reflectors (see Further Details).**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,M).**  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))*          The scalar factors of the elementary reflectors (see Further*          Details).**  WORK    (workspace) DOUBLE PRECISION array, dimension (N)**  INFO    (output) INTEGER*          = 0: successful exit*          < 0: if INFO = -i, the i-th argument had an illegal value**  Further Details*  ===============**  The matrix Q is represented as a product of elementary reflectors**     Q = H(1) H(2) . . . H(k), where k = min(m,n).**  Each H(i) has the form**     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*  and tau in TAU(i).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, K
      DOUBLE PRECISION   AII
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQR2', -INFO )
         RETURN
      END IF
*
      K = MIN( M, N )
*
      DO 10 I = 1, K
*
*        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
         CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
     $                TAU( I ) )
         IF( I.LT.N ) THEN
*
*           Apply H(i) to A(i:m,i+1:n) from the left
*
            AII = A( I, I )
            A( I, I ) = ONE
            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
     $                  A( I, I+1 ), LDA, WORK )
            A( I, I ) = AII
         END IF
   10 CONTINUE
      RETURN
*
*     End of DGEQR2
*
      END
      SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEQRF computes a QR factorization of a real M-by-N matrix A:
*  A = Q * R.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit, the elements on and above the diagonal of the array
*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
*          upper triangular if m >= n); the elements below the diagonal,
*          with the array TAU, represent the orthogonal matrix Q as a
*          product of min(m,n) elementary reflectors (see Further
*          Details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors (see Further
*          Details).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*          For optimum performance LWORK >= N*NB, where NB is
*          the optimal blocksize.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v



























'**  where tau is a real scalar, and v is a real vector with*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),*  and tau in TAU(i).**  =====================================================================**     .. Local Scalars ..      LOGICAL            LQUERY      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,     $                   NBMIN, NX*     ..*     .. External Subroutines ..      EXTERNAL           DGEQR2, DLARFB, DLARFT, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. External Functions ..      INTEGER            ILAENV      EXTERNAL           ILAENV*     ..*     .. Executable Statements ..**     Test the input arguments*      INFO = 0      NB = ILAENV( 1, 'DGEQRF', ' 













', M, N, -1, -1 )      LWKOPT = N*NB      WORK( 1 ) = LWKOPT      LQUERY = ( LWORK.EQ.-1 )      IF( M.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN         INFO = -4      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN         INFO = -7      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGEQRF




















', -INFO )         RETURN      ELSE IF( LQUERY ) THEN         RETURN      END IF**     Quick return if possible*      K = MIN( M, N )      IF( K.EQ.0 ) THEN         WORK( 1 ) = 1         RETURN      END IF*      NBMIN = 2      NX = 0      IWS = N      IF( NB.GT.1 .AND. NB.LT.K ) THEN**        Determine when to cross over from blocked to unblocked code.*         NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' 












', M, N, -1, -1 ) )         IF( NX.LT.K ) THEN**           Determine if workspace is large enough for blocked code.*            LDWORK = N            IWS = LDWORK*NB            IF( LWORK.LT.IWS ) THEN**              Not enough workspace to use optimal NB:  reduce NB and*              determine the minimum value of NB.*               NB = LWORK / LDWORK               NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' 






















', M, N, -1,     $                 -1 ) )            END IF         END IF      END IF*      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN**        Use blocked code initially*         DO 10 I = 1, K - NX, NB            IB = MIN( K-I+1, NB )**           Compute the QR factorization of the current block*           A(i:m,i:i+ib-1)*            CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,     $                   IINFO )            IF( I+IB.LE.N ) THEN**              Form the triangular factor of the block reflector*              H = H(i) H(i+1) . . . H(i+ib-1)*               CALL DLARFT( 'Forward', 'Columnwise


', M-I+1, IB,     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )**              Apply H' to A(i:m,i+ib:n) from the left
*
               CALL DLARFB( 'Left', 'Transpose', 'Forward',
     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
     $                      LDA, WORK( IB+1 ), LDWORK )
            END IF
   10    CONTINUE
      ELSE
         I = 1
      END IF
*
*     Use unblocked code to factor the last or only block.
*
      IF( I.LE.K )
     $   CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                IINFO )
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGEQRF
*
      END
      SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
     $                   X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
*     ..
*
*  Purpose
*  =======
*
*  DGERFS improves the computed solution to a system of linear
*  equations and provides error bounds and backward error estimates for
*  the solution.
*
*  Arguments
*  =========
*
*  TRANS   (input) CHARACTER*1
*          Specifies the form of the system of equations:
*          = 'N':  A * X = B     (No transpose)
*          = 'T':  A**T * X = B  (Transpose)
*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrices B and X.  NRHS >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The original N-by-N matrix A.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)
*          The factors L and U from the factorization A = P*L*U
*          as computed by DGETRF.
*
*  LDAF    (input) INTEGER
*          The leading dimension of the array AF.  LDAF >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          The right hand side matrix B.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
*          On entry, the solution matrix X, as computed by DGETRS.
*          On exit, the improved solution matrix X.
*
*  LDX     (input) INTEGER
*          The leading dimension of the array X.  LDX >= max(1,N).
*
*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
*          The estimated forward error bound for each solution vector
*          X(j) (the j-th column of the solution matrix X).
*          If XTRUE is the true solution corresponding to X(j), FERR(j)
*          is an estimated upper bound for the magnitude of the largest
*          element in (X(j) - XTRUE) divided by the magnitude of the
*          largest element in X(j).  The estimate is as reliable as
*          the estimate for RCOND, and is almost always a slight
*          overestimate of the true error.
*
*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
*          The componentwise relative backward error of each solution
*          vector X(j) (i.e., the smallest relative change in
*          any element of A or B that makes X(j) an exact solution).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
*
*  IWORK   (workspace) INTEGER array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Internal Parameters
*  ===================
*
*  ITMAX is the maximum number of steps of iterative refinement.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN
      CHARACTER          TRANST
      INTEGER            COUNT, I, J, K, KASE, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
*     ..
*     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DGETRS, DLACON, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGERFS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
*
      IF( NOTRAN ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
*
*     NZ = maximum number of nonzero elements in each row of A, plus 1
*
      NZ = N + 1
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
*
*     Do for each right hand side
*
      DO 140 J = 1, NRHS
*
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
*
*        Loop until stopping criterion is satisfied.
*
*        Compute residual R = B - op(A) * X,
*        where op(A) = A, A**T, or A**H, depending on TRANS.
*
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
     $               WORK( N+1 ), 1 )
*
*        Compute componentwise relative backward error from formula
*
*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
*        where abs(Z) is the componentwise absolute value of the matrix
*        or vector Z.  If the i-th component of the denominator is less
*        than SAFE2, then SAFE1 is added to the i-th components of the
*        numerator and denominator before dividing.
*
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
*
*        Compute abs(op(A))*abs(X) + abs(B).
*
         IF( NOTRAN ) THEN
            DO 50 K = 1, N
               XK = ABS( X( K, J ) )
               DO 40 I = 1, N
                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
   40          CONTINUE
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               DO 60 I = 1, N
                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
     $             ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
*
*        Test stopping criterion. Continue iterating if
*           1) The residual BERR(J) is larger than machine epsilon, and
*           2) BERR(J) decreased by at least a factor of 2 during the
*              last iteration, and
*           3) At most ITMAX iterations tried.
*
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
     $       COUNT.LE.ITMAX ) THEN
*
*           Update solution and try again.
*
            CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
     $                   INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
*
*        Bound error from formula
*
*        norm(X - XTRUE) / norm(X) .le. FERR =
*        norm( abs(inv(op(A)))*
*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
*        where
*          norm(Z) is the magnitude of the largest component of Z
*          inv(op(A)) is the inverse of op(A)
*          abs(Z) is the componentwise absolute value of the matrix or
*             vector Z
*          NZ is the maximum number of nonzeros in any row of A, plus 1
*          EPS is machine epsilon
*
*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
*        is incremented by SAFE1 if the i-th component of
*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
*        Use DLACON to estimate the infinity-norm of the matrix
*           inv(op(A)) * diag(W),
*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
*
         KASE = 0
  100    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
     $                KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
*
*              Multiply by diag(W)*inv(op(A)**T).
*
               CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ),
     $                      N, INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  110          CONTINUE
            ELSE
*
*              Multiply by inv(op(A))*diag(W).
*
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  120          CONTINUE
               CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
     $                      INFO )
            END IF
            GO TO 100
         END IF
*
*        Normalize error.
*
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO )
     $      FERR( J ) = FERR( J ) / LSTRES
*
  140 CONTINUE
*
      RETURN
*
*     End of DGERFS
*
      END
      SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGERQ2 computes an RQ factorization of a real m by n matrix A:
*  A = R * Q.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the m by n matrix A.
*          On exit, if m <= n, the upper triangle of the subarray
*          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
*          if m >= n, the elements on and above the (m-n)-th subdiagonal
*          contain the m by n upper trapezoidal matrix R; the remaining
*          elements, with the array TAU, represent the orthogonal matrix
*          Q as a product of elementary reflectors (see Further
*          Details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors (see Further
*          Details).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v


































'**  where tau is a real scalar, and v is a real vector with*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in*  A(m-k+i,1:n-k+i-1), and tau in TAU(i).**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE      PARAMETER          ( ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      INTEGER            I, K      DOUBLE PRECISION   AII*     ..*     .. External Subroutines ..      EXTERNAL           DLARF, DLARFG, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..**     Test the input arguments*      INFO = 0      IF( M.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN         INFO = -4      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGERQ2

















', -INFO )         RETURN      END IF*      K = MIN( M, N )*      DO 10 I = K, 1, -1**        Generate elementary reflector H(i) to annihilate*        A(m-k+i,1:n-k+i-1)*         CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA,     $                TAU( I ) )**        Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right*         AII = A( M-K+I, N-K+I )         A( M-K+I, N-K+I ) = ONE         CALL DLARF( 'Right

















































































', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,     $               TAU( I ), A, LDA, WORK )         A( M-K+I, N-K+I ) = AII   10 CONTINUE      RETURN**     End of DGERQ2*      END      SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            INFO, LDA, LWORK, M, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )*     ..**  Purpose*  =======**  DGERQF computes an RQ factorization of a real M-by-N matrix A:*  A = R * Q.**  Arguments*  =========**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  N       (input) INTEGER*          The number of columns of the matrix A.  N >= 0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the M-by-N matrix A.*          On exit,*          if m <= n, the upper triangle of the subarray*          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;*          if m >= n, the elements on and above the (m-n)-th subdiagonal*          contain the M-by-N upper trapezoidal matrix R;*          the remaining elements, with the array TAU, represent the*          orthogonal matrix Q as a product of min(m,n) elementary*          reflectors (see Further Details).**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,M).**  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))*          The scalar factors of the elementary reflectors (see Further*          Details).**  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.**  LWORK   (input) INTEGER*          The dimension of the array WORK.  LWORK >= max(1,M).*          For optimum performance LWORK >= M*NB, where NB is*          the optimal blocksize.**          If LWORK = -1, then a workspace query is assumed; the routine*          only calculates the optimal size of the WORK array, returns*          this value as the first entry of the WORK array, and no error*          message related to LWORK is issued by XERBLA.**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value**  Further Details*  ===============**  The matrix Q is represented as a product of elementary reflectors**     Q = H(1) H(2) . . . H(k), where k = min(m,n).**  Each H(i) has the form**     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
*  A(m-k+i,1:n-k+i-1), and tau in TAU(i).
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
     $                   MU, NB, NBMIN, NU, NX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGERQ2, DLARFB, DLARFT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
      LWKOPT = M*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGERQF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
      NBMIN = 2
      NX = 1
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
*        Determine when to cross over from blocked to unblocked code.
*
         NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  reduce NB and
*              determine the minimum value of NB.
*
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
*
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
*        Use blocked code initially.
*        The last kk rows are handled by the block method.
*
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
*
         DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
            IB = MIN( K-I+1, NB )
*
*           Compute the RQ factorization of the current block
*           A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1)
*
            CALL DGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ),
     $                   WORK, IINFO )
            IF( M-K+I.GT.1 ) THEN
*
*              Form the triangular factor of the block reflector
*              H = H(i+ib-1) . . . H(i+1) H(i)
*
               CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
     $                      A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK )
*
*              Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
*
               CALL DLARFB( 'Right', 'No transpose', 'Backward',
     $                      'Rowwise', M-K+I-1, N-K+I+IB-1, IB,
     $                      A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA,
     $                      WORK( IB+1 ), LDWORK )
            END IF
   10    CONTINUE
         MU = M - K + I + NB - 1
         NU = N - K + I + NB - 1
      ELSE
         MU = M
         NU = N
      END IF
*
*     Use unblocked code to factor the last or only block
*
      IF( MU.GT.0 .AND. NU.GT.0 )
     $   CALL DGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGERQF
*
      END
      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DGETF2 computes an LU factorization of a general m-by-n matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 2 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the m by n matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
*               has been completed, but the factor U is exactly
*               singular, and division by zero will occur if it is used
*               to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J, JP
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
      DO 10 J = 1, MIN( M, N )
*
*        Find pivot and test for singularity.
*
         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
*
*           Apply the interchange to columns 1:N.
*
            IF( JP.NE.J )
     $         CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
*
*           Compute elements J+1:M of J-th column.
*
            IF( J.LT.M )
     $         CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
*
         ELSE IF( INFO.EQ.0 ) THEN
*
            INFO = J
         END IF
*
         IF( J.LT.MIN( M, N ) ) THEN
*
*           Update trailing submatrix.
*
            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
     $                 A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
*
*     End of DGETF2
*
      END
      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRF computes an LU factorization of a general M-by-N matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
*                has been completed, but the factor U is exactly
*                singular, and division by zero will occur if it is used
*                to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
*        Use unblocked code.
*
         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
*
*        Use blocked code.
*
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
*
*           Factor diagonal and subdiagonal blocks and test for exact
*           singularity.
*
            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
*           Adjust INFO and the pivot indices.
*
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
     $         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
*
*           Apply interchanges to columns 1:J-1.
*
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
            IF( J+JB.LE.N ) THEN
*
*              Apply interchanges to columns J+JB:N.
*
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
     $                      IPIV, 1 )
*
*              Compute block row of U.
*
               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
     $                     LDA )
               IF( J+JB.LE.M ) THEN
*
*                 Update trailing submatrix.
*
                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1,
     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
     $                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
*
*     End of DGETRF
*
      END
      SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRI computes the inverse of a matrix using the LU factorization
*  computed by DGETRF.
*
*  This method inverts U and then computes inv(A) by solving the system
*  inv(A)*L = inv(U) for inv(A).
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the factors L and U from the factorization
*          A = P*L*U as computed by DGETRF.
*          On exit, if INFO = 0, the inverse of the original matrix A.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*          For optimal performance LWORK >= N*NB, where NB is
*          the optimal blocksize returned by ILAENV.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is
*                singular and its inverse could not be computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
     $                   NBMIN, NN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRI', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Form inv(U).  If INFO > 0 from DTRTRI, then U is singular,
*     and the inverse is not computed.
*
      CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
      IF( INFO.GT.0 )
     $   RETURN
*
      NBMIN = 2
      LDWORK = N
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
         IWS = MAX( LDWORK*NB, 1 )
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
         END IF
      ELSE
         IWS = N
      END IF
*
*     Solve the equation inv(A)*L = inv(U) for inv(A).
*
      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
*
*        Use unblocked code.
*
         DO 20 J = N, 1, -1
*
*           Copy current column of L to WORK and replace with zeros.
*
            DO 10 I = J + 1, N
               WORK( I ) = A( I, J )
               A( I, J ) = ZERO
   10       CONTINUE
*
*           Compute current column of inv(A).
*
            IF( J.LT.N )
     $         CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
     $                     LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
   20    CONTINUE
      ELSE
*
*        Use blocked code.
*
         NN = ( ( N-1 ) / NB )*NB + 1
         DO 50 J = NN, 1, -NB
            JB = MIN( NB, N-J+1 )
*
*           Copy current block column of L to WORK and replace with
*           zeros.
*
            DO 40 JJ = J, J + JB - 1
               DO 30 I = JJ + 1, N
                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
                  A( I, JJ ) = ZERO
   30          CONTINUE
   40       CONTINUE
*
*           Compute current block column of inv(A).
*
            IF( J+JB.LE.N )
     $         CALL DGEMM( 'No transpose', 'No transpose', N, JB,
     $                     N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
     $                     WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
            CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
     $                  ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
   50    CONTINUE
      END IF
*
*     Apply column interchanges.
*
      DO 60 J = N - 1, 1, -1
         JP = IPIV( J )
         IF( JP.NE.J )
     $      CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
   60 CONTINUE
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGETRI
*
      END
      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DGETRS solves a system of linear equations
*     A * X = B  or  A








' * X = B*  with a general N-by-N matrix A using the LU factorization computed*  by DGETRF.**  Arguments*  =========**  TRANS   (input) CHARACTER*1*          Specifies the form of the system of equations:*          = 'N
':  A * X = B  (No transpose)*          = 'T':  A'* X = B  (Transpose)
*          = 'C':  A






















































'* X = B  (Conjugate transpose = Transpose)**  N       (input) INTEGER*          The order of the matrix A.  N >= 0.**  NRHS    (input) INTEGER*          The number of right hand sides, i.e., the number of columns*          of the matrix B.  NRHS >= 0.**  A       (input) DOUBLE PRECISION array, dimension (LDA,N)*          The factors L and U from the factorization A = P*L*U*          as computed by DGETRF.**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,N).**  IPIV    (input) INTEGER array, dimension (N)*          The pivot indices from DGETRF; for 1<=i<=N, row i of the*          matrix was interchanged with row IPIV(i).**  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)*          On entry, the right hand side matrix B.*          On exit, the solution matrix X.**  LDB     (input) INTEGER*          The leading dimension of the array B.  LDB >= max(1,N).**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE      PARAMETER          ( ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            NOTRAN*     ..*     .. External Functions ..      LOGICAL            LSAME      EXTERNAL           LSAME*     ..*     .. External Subroutines ..      EXTERNAL           DLASWP, DTRSM, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0      NOTRAN = LSAME( TRANS, 'N
' )      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T
' ) .AND. .NOT.     $    LSAME( TRANS, 'C











' ) ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( NRHS.LT.0 ) THEN         INFO = -3      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN         INFO = -5      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN         INFO = -8      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGETRS


















', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 .OR. NRHS.EQ.0 )     $   RETURN*      IF( NOTRAN ) THEN**        Solve A * X = B.**        Apply row interchanges to the right hand sides.*         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )**        Solve L*X = B, overwriting B with X.*         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit




', N, NRHS,     $               ONE, A, LDA, B, LDB )**        Solve U*X = B, overwriting B with X.*         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit



', N,     $               NRHS, ONE, A, LDA, B, LDB )      ELSE**        Solve A' * X = B.
*
*        Solve U

'*X = B, overwriting B with X.*         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit


', N, NRHS,     $               ONE, A, LDA, B, LDB )**        Solve L'*X = B, overwriting B with X.
*
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
     $               A, LDA, B, LDB )
*
*        Apply row interchanges to the solution vectors.
*
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
*
      RETURN
*
*     End of DGETRS
*
      END
      SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
     $                   LDV, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          JOB, SIDE
      INTEGER            IHI, ILO, INFO, LDV, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   LSCALE( * ), RSCALE( * ), V( LDV, * )
*     ..
*
*  Purpose
*  =======
*
*  DGGBAK forms the right or left eigenvectors of a real generalized
*  eigenvalue problem A*x = lambda*B*x, by backward transformation on
*  the computed eigenvectors of the balanced pair of matrices output by
*  DGGBAL.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          Specifies the type of backward transformation required:
*          = 'N':  do nothing, return immediately;
*          = 'P':  do backward transformation for permutation only;
*          = 'S':  do backward transformation for scaling only;
*          = 'B':  do backward transformations for both permutation and
*                  scaling.
*          JOB must be the same as the argument JOB supplied to DGGBAL.
*
*  SIDE    (input) CHARACTER*1
*          = 'R':  V contains right eigenvectors;
*          = 'L':  V contains left eigenvectors.
*
*  N       (input) INTEGER
*          The number of rows of the matrix V.  N >= 0.
*
*  ILO     (input) INTEGER
*  IHI     (input) INTEGER
*          The integers ILO and IHI determined by DGGBAL.
*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
*
*  LSCALE  (input) DOUBLE PRECISION array, dimension (N)
*          Details of the permutations and/or scaling factors applied
*          to the left side of A and B, as returned by DGGBAL.
*
*  RSCALE  (input) DOUBLE PRECISION array, dimension (N)
*          Details of the permutations and/or scaling factors applied
*          to the right side of A and B, as returned by DGGBAL.
*
*  M       (input) INTEGER
*          The number of columns of the matrix V.  M >= 0.
*
*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,M)
*          On entry, the matrix of right or left eigenvectors to be
*          transformed, as returned by DTGEVC.
*          On exit, V is overwritten by the transformed eigenvectors.
*
*  LDV     (input) INTEGER
*          The leading dimension of the matrix V. LDV >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  See R.C. Ward, Balancing the generalized eigenvalue problem,
*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            LEFTV, RIGHTV
      INTEGER            I, K
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DSCAL, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      RIGHTV = LSAME( SIDE, 'R' )
      LEFTV = LSAME( SIDE, 'L' )
*
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -4
      ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGBAK', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
      IF( M.EQ.0 )
     $   RETURN
      IF( LSAME( JOB, 'N' ) )
     $   RETURN
*
      IF( ILO.EQ.IHI )
     $   GO TO 30
*
*     Backward balance
*
      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
*        Backward transformation on right eigenvectors
*
         IF( RIGHTV ) THEN
            DO 10 I = ILO, IHI
               CALL DSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
   10       CONTINUE
         END IF
*
*        Backward transformation on left eigenvectors
*
         IF( LEFTV ) THEN
            DO 20 I = ILO, IHI
               CALL DSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
   20       CONTINUE
         END IF
      END IF
*
*     Backward permutation
*
   30 CONTINUE
      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
*
*        Backward permutation on right eigenvectors
*
         IF( RIGHTV ) THEN
            IF( ILO.EQ.1 )
     $         GO TO 50
*
            DO 40 I = ILO - 1, 1, -1
               K = RSCALE( I )
               IF( K.EQ.I )
     $            GO TO 40
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
   40       CONTINUE
*
   50       CONTINUE
            IF( IHI.EQ.N )
     $         GO TO 70
            DO 60 I = IHI + 1, N
               K = RSCALE( I )
               IF( K.EQ.I )
     $            GO TO 60
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
   60       CONTINUE
         END IF
*
*        Backward permutation on left eigenvectors
*
   70    CONTINUE
         IF( LEFTV ) THEN
            IF( ILO.EQ.1 )
     $         GO TO 90
            DO 80 I = ILO - 1, 1, -1
               K = LSCALE( I )
               IF( K.EQ.I )
     $            GO TO 80
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
   80       CONTINUE
*
   90       CONTINUE
            IF( IHI.EQ.N )
     $         GO TO 110
            DO 100 I = IHI + 1, N
               K = LSCALE( I )
               IF( K.EQ.I )
     $            GO TO 100
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
  100       CONTINUE
         END IF
      END IF
*
  110 CONTINUE
*
      RETURN
*
*     End of DGGBAK
*
      END
      SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
     $                   RSCALE, WORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            IHI, ILO, INFO, LDA, LDB, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), LSCALE( * ),
     $                   RSCALE( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGGBAL balances a pair of general real matrices (A,B).  This
*  involves, first, permuting A and B by similarity transformations to
*  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
*  elements on the diagonal; and second, applying a diagonal similarity
*  transformation to rows and columns ILO to IHI to make the rows
*  and columns as close in norm as possible. Both steps are optional.
*
*  Balancing may reduce the 1-norm of the matrices, and improve the
*  accuracy of the computed eigenvalues and/or eigenvectors in the
*  generalized eigenvalue problem A*x = lambda*B*x.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          Specifies the operations to be performed on A and B:
*          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
*                  and RSCALE(I) = 1.0 for i = 1,...,N.
*          = 'P':  permute only;
*          = 'S':  scale only;
*          = 'B':  both permute and scale.
*
*  N       (input) INTEGER
*          The order of the matrices A and B.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the input matrix A.
*          On exit,  A is overwritten by the balanced matrix.
*          If JOB = 'N', A is not referenced.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,N).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
*          On entry, the input matrix B.
*          On exit,  B is overwritten by the balanced matrix.
*          If JOB = 'N', B is not referenced.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B. LDB >= max(1,N).
*
*  ILO     (output) INTEGER
*  IHI     (output) INTEGER
*          ILO and IHI are set to integers such that on exit
*          A(i,j) = 0 and B(i,j) = 0 if i > j and
*          j = 1,...,ILO-1 or i = IHI+1,...,N.
*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*
*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)
*          Details of the permutations and scaling factors applied
*          to the left side of A and B.  If P(j) is the index of the
*          row interchanged with row j, and D(j)
*          is the scaling factor applied to row j, then
*            LSCALE(j) = P(j)    for J = 1,...,ILO-1
*                      = D(j)    for J = ILO,...,IHI
*                      = P(j)    for J = IHI+1,...,N.
*          The order in which the interchanges are made is N to IHI+1,
*          then 1 to ILO-1.
*
*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
*          Details of the permutations and scaling factors applied
*          to the right side of A and B.  If P(j) is the index of the
*          column interchanged with column j, and D(j)
*          is the scaling factor applied to column j, then
*            LSCALE(j) = P(j)    for J = 1,...,ILO-1
*                      = D(j)    for J = ILO,...,IHI
*                      = P(j)    for J = IHI+1,...,N.
*          The order in which the interchanges are made is N to IHI+1,
*          then 1 to ILO-1.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  See R.C. WARD, Balancing the generalized eigenvalue problem,
*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   THREE, SCLFAC
      PARAMETER          ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
     $                   K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
     $                   M, NR, NRP2
      DOUBLE PRECISION   ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
     $                   COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
     $                   SFMIN, SUM, T, TA, TB, TC
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG10, MAX, MIN, SIGN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGBAL', -INFO )
         RETURN
      END IF
*
      K = 1
      L = N
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( LSAME( JOB, 'N' ) ) THEN
         ILO = 1
         IHI = N
         DO 10 I = 1, N
            LSCALE( I ) = ONE
            RSCALE( I ) = ONE
   10    CONTINUE
         RETURN
      END IF
*
      IF( K.EQ.L ) THEN
         ILO = 1
         IHI = 1
         LSCALE( 1 ) = ONE
         RSCALE( 1 ) = ONE
         RETURN
      END IF
*
      IF( LSAME( JOB, 'S' ) )
     $   GO TO 190
*
      GO TO 30
*
*     Permute the matrices A and B to isolate the eigenvalues.
*
*     Find row with one nonzero in columns 1 through L
*
   20 CONTINUE
      L = LM1
      IF( L.NE.1 )
     $   GO TO 30
*
      RSCALE( 1 ) = 1
      LSCALE( 1 ) = 1
      GO TO 190
*
   30 CONTINUE
      LM1 = L - 1
      DO 80 I = L, 1, -1
         DO 40 J = 1, LM1
            JP1 = J + 1
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
     $         GO TO 50
   40    CONTINUE
         J = L
         GO TO 70
*
   50    CONTINUE
         DO 60 J = JP1, L
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
     $         GO TO 80
   60    CONTINUE
         J = JP1 - 1
*
   70    CONTINUE
         M = L
         IFLOW = 1
         GO TO 160
   80 CONTINUE
      GO TO 100
*
*     Find column with one nonzero in rows K through N
*
   90 CONTINUE
      K = K + 1
*
  100 CONTINUE
      DO 150 J = K, L
         DO 110 I = K, LM1
            IP1 = I + 1
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
     $         GO TO 120
  110    CONTINUE
         I = L
         GO TO 140
  120    CONTINUE
         DO 130 I = IP1, L
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
     $         GO TO 150
  130    CONTINUE
         I = IP1 - 1
  140    CONTINUE
         M = K
         IFLOW = 2
         GO TO 160
  150 CONTINUE
      GO TO 190
*
*     Permute rows M and I
*
  160 CONTINUE
      LSCALE( M ) = I
      IF( I.EQ.M )
     $   GO TO 170
      CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
      CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
*
*     Permute columns M and J
*
  170 CONTINUE
      RSCALE( M ) = J
      IF( J.EQ.M )
     $   GO TO 180
      CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
      CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
*
  180 CONTINUE
      GO TO ( 20, 90 )IFLOW
*
  190 CONTINUE
      ILO = K
      IHI = L
*
      IF( ILO.EQ.IHI )
     $   RETURN
*
      IF( LSAME( JOB, 'P' ) )
     $   RETURN
*
*     Balance the submatrix in rows ILO to IHI.
*
      NR = IHI - ILO + 1
      DO 200 I = ILO, IHI
         RSCALE( I ) = ZERO
         LSCALE( I ) = ZERO
*
         WORK( I ) = ZERO
         WORK( I+N ) = ZERO
         WORK( I+2*N ) = ZERO
         WORK( I+3*N ) = ZERO
         WORK( I+4*N ) = ZERO
         WORK( I+5*N ) = ZERO
  200 CONTINUE
*
*     Compute right side vector in resulting linear equations
*
      BASL = LOG10( SCLFAC )
      DO 240 I = ILO, IHI
         DO 230 J = ILO, IHI
            TB = B( I, J )
            TA = A( I, J )
            IF( TA.EQ.ZERO )
     $         GO TO 210
            TA = LOG10( ABS( TA ) ) / BASL
  210       CONTINUE
            IF( TB.EQ.ZERO )
     $         GO TO 220
            TB = LOG10( ABS( TB ) ) / BASL
  220       CONTINUE
            WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
            WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
  230    CONTINUE
  240 CONTINUE
*
      COEF = ONE / DBLE( 2*NR )
      COEF2 = COEF*COEF
      COEF5 = HALF*COEF2
      NRP2 = NR + 2
      BETA = ZERO
      IT = 1
*
*     Start generalized conjugate gradient iteration
*
  250 CONTINUE
*
      GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
     $        DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
*
      EW = ZERO
      EWC = ZERO
      DO 260 I = ILO, IHI
         EW = EW + WORK( I+4*N )
         EWC = EWC + WORK( I+5*N )
  260 CONTINUE
*
      GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
      IF( GAMMA.EQ.ZERO )
     $   GO TO 350
      IF( IT.NE.1 )
     $   BETA = GAMMA / PGAMMA
      T = COEF5*( EWC-THREE*EW )
      TC = COEF5*( EW-THREE*EWC )
*
      CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
      CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
*
      CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
      CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
*
      DO 270 I = ILO, IHI
         WORK( I ) = WORK( I ) + TC
         WORK( I+N ) = WORK( I+N ) + T
  270 CONTINUE
*
*     Apply matrix to vector
*
      DO 300 I = ILO, IHI
         KOUNT = 0
         SUM = ZERO
         DO 290 J = ILO, IHI
            IF( A( I, J ).EQ.ZERO )
     $         GO TO 280
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( J )
  280       CONTINUE
            IF( B( I, J ).EQ.ZERO )
     $         GO TO 290
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( J )
  290    CONTINUE
         WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
  300 CONTINUE
*
      DO 330 J = ILO, IHI
         KOUNT = 0
         SUM = ZERO
         DO 320 I = ILO, IHI
            IF( A( I, J ).EQ.ZERO )
     $         GO TO 310
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( I+N )
  310       CONTINUE
            IF( B( I, J ).EQ.ZERO )
     $         GO TO 320
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( I+N )
  320    CONTINUE
         WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
  330 CONTINUE
*
      SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
     $      DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
      ALPHA = GAMMA / SUM
*
*     Determine correction to current iteration
*
      CMAX = ZERO
      DO 340 I = ILO, IHI
         COR = ALPHA*WORK( I+N )
         IF( ABS( COR ).GT.CMAX )
     $      CMAX = ABS( COR )
         LSCALE( I ) = LSCALE( I ) + COR
         COR = ALPHA*WORK( I )
         IF( ABS( COR ).GT.CMAX )
     $      CMAX = ABS( COR )
         RSCALE( I ) = RSCALE( I ) + COR
  340 CONTINUE
      IF( CMAX.LT.HALF )
     $   GO TO 350
*
      CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
      CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
*
      PGAMMA = GAMMA
      IT = IT + 1
      IF( IT.LE.NRP2 )
     $   GO TO 250
*
*     End generalized conjugate gradient iteration
*
  350 CONTINUE
      SFMIN = DLAMCH( 'S' )
      SFMAX = ONE / SFMIN
      LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
      LSFMAX = INT( LOG10( SFMAX ) / BASL )
      DO 360 I = ILO, IHI
         IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA )
         RAB = ABS( A( I, IRAB+ILO-1 ) )
         IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDA )
         RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
         LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
         IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
         IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
         LSCALE( I ) = SCLFAC**IR
         ICAB = IDAMAX( IHI, A( 1, I ), 1 )
         CAB = ABS( A( ICAB, I ) )
         ICAB = IDAMAX( IHI, B( 1, I ), 1 )
         CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
         LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
         JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
         JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
         RSCALE( I ) = SCLFAC**JC
  360 CONTINUE
*
*     Row scaling of matrices A and B
*
      DO 370 I = ILO, IHI
         CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
         CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
  370 CONTINUE
*
*     Column scaling of matrices A and B
*
      DO 380 J = ILO, IHI
         CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
         CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
  380 CONTINUE
*
      RETURN
*
*     End of DGGBAL
*
      END
      SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
     $                   LDQ, Z, LDZ, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  DGGHRD reduces a pair of real matrices (A,B) to generalized upper
*  Hessenberg form using orthogonal transformations, where A is a
*  general matrix and B is upper triangular:  Q
' * A * Z = H and*  Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular,
*  and Q and Z are orthogonal, and 





' means transpose.**  The orthogonal matrices Q and Z are determined as products of Givens*  rotations.  They may either be formed explicitly, or they may be*  postmultiplied into input matrices Q1 and Z1, so that**       Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)
'*       Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)





'**  Arguments*  =========**  COMPQ   (input) CHARACTER*1*          = 'N
': do not compute Q;*          = 'I

': Q is initialized to the unit matrix, and the*                 orthogonal matrix Q is returned;*          = 'V



': Q must contain an orthogonal matrix Q1 on entry,*                 and the product Q1*Q is returned.**  COMPZ   (input) CHARACTER*1*          = 'N
': do not compute Z;*          = 'I

': Z is initialized to the unit matrix, and the*                 orthogonal matrix Z is returned;*          = 'V
























': Z must contain an orthogonal matrix Z1 on entry,*                 and the product Z1*Z is returned.**  N       (input) INTEGER*          The order of the matrices A and B.  N >= 0.**  ILO     (input) INTEGER*  IHI     (input) INTEGER*          It is assumed that A is already upper triangular in rows and*          columns 1:ILO-1 and IHI+1:N.  ILO and IHI are normally set*          by a previous call to DGGBAL; otherwise they should be set*          to 1 and N respectively.*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)*          On entry, the N-by-N general matrix to be reduced.*          On exit, the upper triangle and the first subdiagonal of A*          are overwritten with the upper Hessenberg matrix H, and the*          rest is set to zero.**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max(1,N).**  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)*          On entry, the N-by-N upper triangular matrix B.*          On exit, the upper triangular matrix T = Q' B Z.  The
*          elements below the diagonal are set to zero.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
*          If COMPQ='N':  Q is not referenced.
*          If COMPQ='I':  on entry, Q need not be set, and on exit it
*                         contains the orthogonal matrix Q, where Q


'*                         is the product of the Givens transformations*                         which are applied to A and B on the left.*          If COMPQ='V




':  on entry, Q must contain an orthogonal matrix*                         Q1, and on exit this is overwritten by Q1*Q.**  LDQ     (input) INTEGER*          The leading dimension of the array Q.*          LDQ >= N if COMPQ='V' or 'I


'; LDQ >= 1 otherwise.**  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)*          If COMPZ='N
':  Z is not referenced.*          If COMPZ='I



':  on entry, Z need not be set, and on exit it*                         contains the orthogonal matrix Z, which is*                         the product of the Givens transformations*                         which are applied to A and B on the right.*          If COMPZ='V




':  on entry, Z must contain an orthogonal matrix*                         Z1, and on exit this is overwritten by Z1*Z.**  LDZ     (input) INTEGER*          The leading dimension of the array Z.*          LDZ >= N if COMPZ='V' or 'I





































'; LDZ >= 1 otherwise.**  INFO    (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  This routine reduces A to Hessenberg and B to triangular form by*  an unblocked reduction, as described in _Matrix_Computations_,*  by Golub and Van Loan (Johns Hopkins Press.)**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            ILQ, ILZ      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW      DOUBLE PRECISION   C, S, TEMP*     ..*     .. External Functions ..      LOGICAL            LSAME      EXTERNAL           LSAME*     ..*     .. External Subroutines ..      EXTERNAL           DLARTG, DLASET, DROT, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX*     ..*     .. Executable Statements ..**     Decode COMPQ*      IF( LSAME( COMPQ, 'N


' ) ) THEN         ILQ = .FALSE.         ICOMPQ = 1      ELSE IF( LSAME( COMPQ, 'V


' ) ) THEN         ILQ = .TRUE.         ICOMPQ = 2      ELSE IF( LSAME( COMPQ, 'I








' ) ) THEN         ILQ = .TRUE.         ICOMPQ = 3      ELSE         ICOMPQ = 0      END IF**     Decode COMPZ*      IF( LSAME( COMPZ, 'N


' ) ) THEN         ILZ = .FALSE.         ICOMPZ = 1      ELSE IF( LSAME( COMPZ, 'V


' ) ) THEN         ILZ = .TRUE.         ICOMPZ = 2      ELSE IF( LSAME( COMPZ, 'I





























' ) ) THEN         ILZ = .TRUE.         ICOMPZ = 3      ELSE         ICOMPZ = 0      END IF**     Test the input parameters.*      INFO = 0      IF( ICOMPQ.LE.0 ) THEN         INFO = -1      ELSE IF( ICOMPZ.LE.0 ) THEN         INFO = -2      ELSE IF( N.LT.0 ) THEN         INFO = -3      ELSE IF( ILO.LT.1 ) THEN         INFO = -4      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN         INFO = -5      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN         INFO = -7      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN         INFO = -9      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN         INFO = -11      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN         INFO = -13      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGGHRD






', -INFO )         RETURN      END IF**     Initialize Q and Z if desired.*      IF( ICOMPQ.EQ.3 )     $   CALL DLASET( 'Full

', N, N, ZERO, ONE, Q, LDQ )      IF( ICOMPZ.EQ.3 )     $   CALL DLASET( 'Full






























































































', N, N, ZERO, ONE, Z, LDZ )**     Quick return if possible*      IF( N.LE.1 )     $   RETURN**     Zero out lower triangle of B*      DO 20 JCOL = 1, N - 1         DO 10 JROW = JCOL + 1, N            B( JROW, JCOL ) = ZERO   10    CONTINUE   20 CONTINUE**     Reduce A and B*      DO 40 JCOL = ILO, IHI - 2*         DO 30 JROW = IHI, JCOL + 2, -1**           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)*            TEMP = A( JROW-1, JCOL )            CALL DLARTG( TEMP, A( JROW, JCOL ), C, S,     $                   A( JROW-1, JCOL ) )            A( JROW, JCOL ) = ZERO            CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,     $                 A( JROW, JCOL+1 ), LDA, C, S )            CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,     $                 B( JROW, JROW-1 ), LDB, C, S )            IF( ILQ )     $         CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )**           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)*            TEMP = B( JROW, JROW )            CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S,     $                   B( JROW, JROW ) )            B( JROW, JROW-1 ) = ZERO            CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )            CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,     $                 S )            IF( ILZ )     $         CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )   30    CONTINUE   40 CONTINUE*      RETURN**     End of DGGHRD*      END      SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK,     $                   LWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            INFO, LDA, LDB, LWORK, M, N, P*     ..*     .. Array Arguments ..      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),     $                   WORK( * )*     ..**  Purpose*  =======**  DGGQRF computes a generalized QR factorization of an N-by-M matrix A*  and an N-by-P matrix B:**              A = Q*R,        B = Q*T*Z,**  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal*  matrix, and R and T assume one of the forms:**  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,*                  (  0  ) N-M                         N   M-N*                     M**  where R11 is upper triangular, and**  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,*                   P-N  N                           ( T21 ) P*                                                       P**  where T12 or T21 is upper triangular.**  In particular, if B is square and nonsingular, the GQR factorization*  of A and B implicitly gives the QR factorization of inv(B)*A:**               inv(B)*A = Z'*(inv(T)*R)
*
*  where inv(B) denotes the inverse of the matrix B, and Z












































































' denotes the*  transpose of the matrix Z.**  Arguments*  =========**  N       (input) INTEGER*          The number of rows of the matrices A and B. N >= 0.**  M       (input) INTEGER*          The number of columns of the matrix A.  M >= 0.**  P       (input) INTEGER*          The number of columns of the matrix B.  P >= 0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)*          On entry, the N-by-M matrix A.*          On exit, the elements on and above the diagonal of the array*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is*          upper triangular if N >= M); the elements below the diagonal,*          with the array TAUA, represent the orthogonal matrix Q as a*          product of min(N,M) elementary reflectors (see Further*          Details).**  LDA     (input) INTEGER*          The leading dimension of the array A. LDA >= max(1,N).**  TAUA    (output) DOUBLE PRECISION array, dimension (min(N,M))*          The scalar factors of the elementary reflectors which*          represent the orthogonal matrix Q (see Further Details).**  B       (input/output) DOUBLE PRECISION array, dimension (LDB,P)*          On entry, the N-by-P matrix B.*          On exit, if N <= P, the upper triangle of the subarray*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;*          if N > P, the elements on and above the (N-P)-th subdiagonal*          contain the N-by-P upper trapezoidal matrix T; the remaining*          elements, with the array TAUB, represent the orthogonal*          matrix Z as a product of elementary reflectors (see Further*          Details).**  LDB     (input) INTEGER*          The leading dimension of the array B. LDB >= max(1,N).**  TAUB    (output) DOUBLE PRECISION array, dimension (min(N,P))*          The scalar factors of the elementary reflectors which*          represent the orthogonal matrix Z (see Further Details).**  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.**  LWORK   (input) INTEGER*          The dimension of the array WORK. LWORK >= max(1,N,M,P).*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),*          where NB1 is the optimal blocksize for the QR factorization*          of an N-by-M matrix, NB2 is the optimal blocksize for the*          RQ factorization of an N-by-P matrix, and NB3 is the optimal*          blocksize for a call of DORMQR.**          If LWORK = -1, then a workspace query is assumed; the routine*          only calculates the optimal size of the WORK array, returns*          this value as the first entry of the WORK array, and no error*          message related to LWORK is issued by XERBLA.**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  The matrix Q is represented as a product of elementary reflectors**     Q = H(1) H(2) . . . H(k), where k = min(n,m).**  Each H(i) has the form**     H(i) = I - taua * v * v'
*
*  where taua is a real scalar, and v is a real vector with
*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
*  and taua in TAUA(i).
*  To form Q explicitly, use LAPACK subroutine DORGQR.
*  To use Q to update another matrix, use LAPACK subroutine DORMQR.
*
*  The matrix Z is represented as a product of elementary reflectors
*
*     Z = H(1) H(2) . . . H(k), where k = min(n,p).
*
*  Each H(i) has the form
*
*     H(i) = I - taub * v * v




























'**  where taub is a real scalar, and v is a real vector with*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).*  To form Z explicitly, use LAPACK subroutine DORGRQ.*  To use Z to update another matrix, use LAPACK subroutine DORMRQ.**  =====================================================================**     .. Local Scalars ..      LOGICAL            LQUERY      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3*     ..*     .. External Subroutines ..      EXTERNAL           DGEQRF, DGERQF, DORMQR, XERBLA*     ..*     .. External Functions ..      INTEGER            ILAENV      EXTERNAL           ILAENV*     ..*     .. Intrinsic Functions ..      INTRINSIC          INT, MAX, MIN*     ..*     .. Executable Statements ..**     Test the input parameters*      INFO = 0      NB1 = ILAENV( 1, 'DGEQRF', ' 
', N, M, -1, -1 )      NB2 = ILAENV( 1, 'DGERQF', ' 
', N, P, -1, -1 )      NB3 = ILAENV( 1, 'DORMQR', ' 


















', N, M, P, -1 )      NB = MAX( NB1, NB2, NB3 )      LWKOPT = MAX( N, M, P )*NB      WORK( 1 ) = LWKOPT      LQUERY = ( LWORK.EQ.-1 )      IF( N.LT.0 ) THEN         INFO = -1      ELSE IF( M.LT.0 ) THEN         INFO = -2      ELSE IF( P.LT.0 ) THEN         INFO = -3      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN         INFO = -5      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN         INFO = -8      ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN         INFO = -11      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGGQRF










', -INFO )         RETURN      ELSE IF( LQUERY ) THEN         RETURN      END IF**     QR factorization of N-by-M matrix A: A = Q*R*      CALL DGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )      LOPT = WORK( 1 )**     Update B := Q'*B.
*
      CALL DORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA,
     $             B, LDB, WORK, LWORK, INFO )
      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
*
*     RQ factorization of N-by-P matrix B: B = T*Z.
*
      CALL DGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
*
      RETURN
*
*     End of DGGQRF
*
      END
      SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK,
     $                   LWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGGRQF computes a generalized RQ factorization of an M-by-N matrix A
*  and a P-by-N matrix B:
*
*              A = R*Q,        B = Z*T*Q,
*
*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
*  matrix, and R and T assume one of the forms:
*
*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,
*                   N-M  M                           ( R21 ) N
*                                                       N
*
*  where R12 or R21 is upper triangular, and
*
*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,
*                  (  0  ) P-N                         P   N-P
*                     N
*
*  where T11 is upper triangular.
*
*  In particular, if B is square and nonsingular, the GRQ factorization
*  of A and B implicitly gives the RQ factorization of A*inv(B):
*
*               A*inv(B) = (R*inv(T))*Z

'**  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
*  transpose of the matrix Z.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  P       (input) INTEGER
*          The number of rows of the matrix B.  P >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrices A and B. N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit, if M <= N, the upper triangle of the subarray
*          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
*          if M > N, the elements on and above the (M-N)-th subdiagonal
*          contain the M-by-N upper trapezoidal matrix R; the remaining
*          elements, with the array TAUA, represent the orthogonal
*          matrix Q as a product of elementary reflectors (see Further
*          Details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,M).
*
*  TAUA    (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors which
*          represent the orthogonal matrix Q (see Further Details).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
*          On entry, the P-by-N matrix B.
*          On exit, the elements on and above the diagonal of the array
*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is
*          upper triangular if P >= N); the elements below the diagonal,
*          with the array TAUB, represent the orthogonal matrix Z as a
*          product of elementary reflectors (see Further Details).
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B. LDB >= max(1,P).
*
*  TAUB    (output) DOUBLE PRECISION array, dimension (min(P,N))
*          The scalar factors of the elementary reflectors which
*          represent the orthogonal matrix Z (see Further Details).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK >= max(1,N,M,P).
*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
*          where NB1 is the optimal blocksize for the RQ factorization
*          of an M-by-N matrix, NB2 is the optimal blocksize for the
*          QR factorization of a P-by-N matrix, and NB3 is the optimal
*          blocksize for a call of DORMRQ.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INF0= -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
*
*  Each H(i) has the form
*
*     H(i) = I - taua * v * v













'**  where taua is a real scalar, and v is a real vector with*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).*  To form Q explicitly, use LAPACK subroutine DORGRQ.*  To use Q to update another matrix, use LAPACK subroutine DORMRQ.**  The matrix Z is represented as a product of elementary reflectors**     Z = H(1) H(2) . . . H(k), where k = min(p,n).**  Each H(i) has the form**     H(i) = I - taub * v * v'
*
*  where taub is a real scalar, and v is a real vector with
*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
*  and taub in TAUB(i).
*  To form Z explicitly, use LAPACK subroutine DORGQR.
*  To use Z to update another matrix, use LAPACK subroutine DORMQR.
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGERQF, DORMRQ, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      NB1 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
      NB2 = ILAENV( 1, 'DGEQRF', ' ', P, N, -1, -1 )
      NB3 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
      NB = MAX( NB1, NB2, NB3 )
      LWKOPT = MAX( N, M, P )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( P.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGRQF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     RQ factorization of M-by-N matrix A: A = R*Q
*
      CALL DGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
      LOPT = WORK( 1 )
*
*     Update B := B*Q

'*      CALL DORMRQ( 'Right', 'Transpose








































', P, N, MIN( M, N ),     $             A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,     $             LWORK, INFO )      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )**     QR factorization of P-by-N matrix B: B = Z*T*      CALL DGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )*      RETURN**     End of DGGRQF*      END      SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,     $                   TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ,     $                   IWORK, TAU, WORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          JOBQ, JOBU, JOBV      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P      DOUBLE PRECISION   TOLA, TOLB*     ..*     .. Array Arguments ..      INTEGER            IWORK( * )      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ),     $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )*     ..**  Purpose*  =======**  DGGSVP computes orthogonal matrices U, V and Q such that**                   N-K-L  K    L*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;
*                L ( 0     0   A23 )
*            M-K-L ( 0     0    0  )
*
*                   N-K-L  K    L
*          =     K ( 0    A12  A13 )  if M-K-L < 0;
*              M-K ( 0     0   A23 )
*
*                 N-K-L  K    L
*   V





'*B*Q =   L ( 0     0   B13 )*            P-L ( 0     0    0  )**  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z










' denotes the*  transpose of Z.**  This decomposition is the preprocessing step for computing the*  Generalized Singular Value Decomposition (GSVD), see subroutine*  DGGSVD.**  Arguments*  =========**  JOBU    (input) CHARACTER*1*          = 'U
':  Orthogonal matrix U is computed;*          = 'N


':  U is not computed.**  JOBV    (input) CHARACTER*1*          = 'V
':  Orthogonal matrix V is computed;*          = 'N


':  V is not computed.**  JOBQ    (input) CHARACTER*1*          = 'Q
':  Orthogonal matrix Q is computed;*          = 'N








































':  Q is not computed.**  M       (input) INTEGER*          The number of rows of the matrix A.  M >= 0.**  P       (input) INTEGER*          The number of rows of the matrix B.  P >= 0.**  N       (input) INTEGER*          The number of columns of the matrices A and B.  N >= 0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)*          On entry, the M-by-N matrix A.*          On exit, A contains the triangular (or trapezoidal) matrix*          described in the Purpose section.**  LDA     (input) INTEGER*          The leading dimension of the array A. LDA >= max(1,M).**  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)*          On entry, the P-by-N matrix B.*          On exit, B contains the triangular matrix described in*          the Purpose section.**  LDB     (input) INTEGER*          The leading dimension of the array B. LDB >= max(1,P).**  TOLA    (input) DOUBLE PRECISION*  TOLB    (input) DOUBLE PRECISION*          TOLA and TOLB are the thresholds to determine the effective*          numerical rank of matrix B and a subblock of A. Generally,*          they are set to*             TOLA = MAX(M,N)*norm(A)*MAZHEPS,*             TOLB = MAX(P,N)*norm(B)*MAZHEPS.*          The size of TOLA and TOLB may affect the size of backward*          errors of the decomposition.**  K       (output) INTEGER*  L       (output) INTEGER*          On exit, K and L specify the dimension of the subblocks*          described in Purpose.*          K + L = effective numerical rank of (A',B')'.
*
*  U       (output) DOUBLE PRECISION array, dimension (LDU,M)
*          If JOBU = 'U', U contains the orthogonal matrix U.
*          If JOBU = 'N', U is not referenced.
*
*  LDU     (input) INTEGER
*          The leading dimension of the array U. LDU >= max(1,M) if
*          JOBU = 'U'; LDU >= 1 otherwise.
*
*  V       (output) DOUBLE PRECISION array, dimension (LDV,M)
*          If JOBV = 'V', V contains the orthogonal matrix V.
*          If JOBV = 'N', V is not referenced.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V. LDV >= max(1,P) if
*          JOBV = 'V'; LDV >= 1 otherwise.
*
*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
*          If JOBQ = 'Q', Q contains the orthogonal matrix Q.
*          If JOBQ = 'N', Q is not referenced.
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q. LDQ >= max(1,N) if
*          JOBQ = 'Q'; LDQ >= 1 otherwise.
*
*  IWORK   (workspace) INTEGER array, dimension (N)
*
*  TAU     (workspace) DOUBLE PRECISION array, dimension (N)
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*
*  Further Details
*  ===============
*
*  The subroutine uses LAPACK subroutine DGEQPF for the QR factorization
*  with column pivoting to detect the effective numerical rank of the
*  a matrix. It may be replaced by a better rank determination strategy.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FORWRD, WANTQ, WANTU, WANTV
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEQPF, DGEQR2, DGERQ2, DLACPY, DLAPMT, DLASET,
     $                   DORG2R, DORM2R, DORMR2, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      WANTU = LSAME( JOBU, 'U' )
      WANTV = LSAME( JOBV, 'V' )
      WANTQ = LSAME( JOBQ, 'Q' )
      FORWRD = .TRUE.
*
      INFO = 0
      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
         INFO = -16
      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
         INFO = -18
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
         INFO = -20
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGSVP', -INFO )
         RETURN
      END IF
*
*     QR with column pivoting of B: B*P = V*( S11 S12 )
*                                           (  0   0  )
*
      DO 10 I = 1, N
         IWORK( I ) = 0
   10 CONTINUE
      CALL DGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO )
*
*     Update A := A*P
*
      CALL DLAPMT( FORWRD, M, N, A, LDA, IWORK )
*
*     Determine the effective rank of matrix B.
*
      L = 0
      DO 20 I = 1, MIN( P, N )
         IF( ABS( B( I, I ) ).GT.TOLB )
     $      L = L + 1
   20 CONTINUE
*
      IF( WANTV ) THEN
*
*        Copy the details of V, and form V.
*
         CALL DLASET( 'Full', P, P, ZERO, ZERO, V, LDV )
         IF( P.GT.1 )
     $      CALL DLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
     $                   LDV )
         CALL DORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
      END IF
*
*     Clean up B
*
      DO 40 J = 1, L - 1
         DO 30 I = J + 1, L
            B( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
      IF( P.GT.L )
     $   CALL DLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB )
*
      IF( WANTQ ) THEN
*
*        Set Q = I and Update Q := Q*P
*
         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
         CALL DLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
      END IF
*
      IF( P.GE.L .AND. N.NE.L ) THEN
*
*        RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z
*
         CALL DGERQ2( L, N, B, LDB, TAU, WORK, INFO )
*
*        Update A := A*Z

'*         CALL DORMR2( 'Right', 'Transpose




', M, N, L, B, LDB, TAU, A,     $                LDA, WORK, INFO )*         IF( WANTQ ) THEN**           Update Q := Q*Z'
*
            CALL DORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q,
     $                   LDQ, WORK, INFO )
         END IF
*
*        Clean up B
*
         CALL DLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB )
         DO 60 J = N - L + 1, N
            DO 50 I = J - N + L + 1, L
               B( I, J ) = ZERO
   50       CONTINUE
   60    CONTINUE
*
      END IF
*
*     Let              N-L     L
*                A = ( A11    A12 ) M,
*
*     then the following does the complete QR decomposition of A11:
*
*              A11 = U*(  0  T12 )*P1















'*                      (  0   0  )*      DO 70 I = 1, N - L         IWORK( I ) = 0   70 CONTINUE      CALL DGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO )**     Determine the effective rank of A11*      K = 0      DO 80 I = 1, MIN( M, N-L )         IF( ABS( A( I, I ) ).GT.TOLA )     $      K = K + 1   80 CONTINUE**     Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
*
      CALL DORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA,
     $             TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
*
      IF( WANTU ) THEN
*
*        Copy the details of U, and form U
*
         CALL DLASET( 'Full', M, M, ZERO, ZERO, U, LDU )
         IF( M.GT.1 )
     $      CALL DLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
     $                   LDU )
         CALL DORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
      END IF
*
      IF( WANTQ ) THEN
*
*        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1
*
         CALL DLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
      END IF
*
*     Clean up A: set the strictly lower triangular part of
*     A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
*
      DO 100 J = 1, K - 1
         DO 90 I = J + 1, K
            A( I, J ) = ZERO
   90    CONTINUE
  100 CONTINUE
      IF( M.GT.K )
     $   CALL DLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA )
*
      IF( N-L.GT.K ) THEN
*
*        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
*
         CALL DGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
*
         IF( WANTQ ) THEN
*
*           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1

'*            CALL DORMR2( 'Right', 'Transpose





', N, N-L, K, A, LDA, TAU,     $                   Q, LDQ, WORK, INFO )         END IF**        Clean up A*         CALL DLASET( 'Full


















', K, N-L-K, ZERO, ZERO, A, LDA )         DO 120 J = N - L - K + 1, N - L            DO 110 I = J - N + L + K + 1, K               A( I, J ) = ZERO  110       CONTINUE  120    CONTINUE*      END IF*      IF( M.GT.K ) THEN**        QR factorization of A( K+1:M,N-L+1:N )*         CALL DGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )*         IF( WANTU ) THEN**           Update U(:,K+1:M) := U(:,K+1:M)*U1*            CALL DORM2R( 'Right', 'No transpose





















































', M, M-K, MIN( M-K, L ),     $                   A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,     $                   WORK, INFO )         END IF**        Clean up*         DO 140 J = N - L + 1, N            DO 130 I = J - N + K + L + 1, M               A( I, J ) = ZERO  130       CONTINUE  140    CONTINUE*      END IF*      RETURN**     End of DGGSVP*      END      SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,     $                   WORK, IWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          NORM      INTEGER            INFO, N      DOUBLE PRECISION   ANORM, RCOND*     ..*     .. Array Arguments ..      INTEGER            IPIV( * ), IWORK( * )      DOUBLE PRECISION   D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )*     ..**  Purpose*  =======**  DGTCON estimates the reciprocal of the condition number of a real*  tridiagonal matrix A using the LU factorization as computed by*  DGTTRF.**  An estimate is obtained for norm(inv(A)), and the reciprocal of the*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).**  Arguments*  =========**  NORM    (input) CHARACTER*1*          Specifies whether the 1-norm condition number or the*          infinity-norm condition number is required:*          = '1' or 'O
':  1-norm;*          = 'I

























':         Infinity-norm.**  N       (input) INTEGER*          The order of the matrix A.  N >= 0.**  DL      (input) DOUBLE PRECISION array, dimension (N-1)*          The (n-1) multipliers that define the matrix L from the*          LU factorization of A as computed by DGTTRF.**  D       (input) DOUBLE PRECISION array, dimension (N)*          The n diagonal elements of the upper triangular matrix U from*          the LU factorization of A.**  DU      (input) DOUBLE PRECISION array, dimension (N-1)*          The (n-1) elements of the first superdiagonal of U.**  DU2     (input) DOUBLE PRECISION array, dimension (N-2)*          The (n-2) elements of the second superdiagonal of U.**  IPIV    (input) INTEGER array, dimension (N)*          The pivot indices; for 1 <= i <= n, row i of the matrix was*          interchanged with row IPIV(i).  IPIV(i) will always be either*          i or i+1; IPIV(i) = i indicates a row interchange was not*          required.**  ANORM   (input) DOUBLE PRECISION*          If NORM = '1' or 'O
', the 1-norm of the original matrix A.*          If NORM = 'I





































', the infinity-norm of the original matrix A.**  RCOND   (output) DOUBLE PRECISION*          The reciprocal of the condition number of the matrix A,*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an*          estimate of the 1-norm of inv(A) computed in this routine.**  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)**  IWORK   (workspace) INTEGER array, dimension (N)**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            ONENRM      INTEGER            I, KASE, KASE1      DOUBLE PRECISION   AINVNM*     ..*     .. External Functions ..      LOGICAL            LSAME      EXTERNAL           LSAME*     ..*     .. External Subroutines ..      EXTERNAL           DGTTRS, DLACON, XERBLA*     ..*     .. Executable Statements ..**     Test the input arguments.*      INFO = 0      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O
' )      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I







' ) ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( ANORM.LT.ZERO ) THEN         INFO = -8      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGTCON


































', -INFO )         RETURN      END IF**     Quick return if possible*      RCOND = ZERO      IF( N.EQ.0 ) THEN         RCOND = ONE         RETURN      ELSE IF( ANORM.EQ.ZERO ) THEN         RETURN      END IF**     Check that D(1:N) is non-zero.*      DO 10 I = 1, N         IF( D( I ).EQ.ZERO )     $      RETURN   10 CONTINUE*      AINVNM = ZERO      IF( ONENRM ) THEN         KASE1 = 1      ELSE         KASE1 = 2      END IF      KASE = 0   20 CONTINUE      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )      IF( KASE.NE.0 ) THEN         IF( KASE.EQ.KASE1 ) THEN**           Multiply by inv(U)*inv(L).*            CALL DGTTRS( 'No transpose



', N, 1, DL, D, DU, DU2, IPIV,     $                   WORK, N, INFO )         ELSE**           Multiply by inv(L')*inv(U

').*            CALL DGTTRS( 'Transpose















































', N, 1, DL, D, DU, DU2, IPIV, WORK,     $                   N, INFO )         END IF         GO TO 20      END IF**     Compute the estimate of the reciprocal condition number.*      IF( AINVNM.NE.ZERO )     $   RCOND = ( ONE / AINVNM ) / ANORM*      RETURN**     End of DGTCON*      END      SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,     $                   IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,     $                   INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          TRANS      INTEGER            INFO, LDB, LDX, N, NRHS*     ..*     .. Array Arguments ..      INTEGER            IPIV( * ), IWORK( * )      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),     $                   DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),     $                   FERR( * ), WORK( * ), X( LDX, * )*     ..**  Purpose*  =======**  DGTRFS improves the computed solution to a system of linear*  equations when the coefficient matrix is tridiagonal, and provides*  error bounds and backward error estimates for the solution.**  Arguments*  =========**  TRANS   (input) CHARACTER*1*          Specifies the form of the system of equations:*          = 'N
':  A * X = B     (No transpose)*          = 'T
':  A**T * X = B  (Transpose)*          = 'C
















































































































':  A**H * X = B  (Conjugate transpose = Transpose)**  N       (input) INTEGER*          The order of the matrix A.  N >= 0.**  NRHS    (input) INTEGER*          The number of right hand sides, i.e., the number of columns*          of the matrix B.  NRHS >= 0.**  DL      (input) DOUBLE PRECISION array, dimension (N-1)*          The (n-1) subdiagonal elements of A.**  D       (input) DOUBLE PRECISION array, dimension (N)*          The diagonal elements of A.**  DU      (input) DOUBLE PRECISION array, dimension (N-1)*          The (n-1) superdiagonal elements of A.**  DLF     (input) DOUBLE PRECISION array, dimension (N-1)*          The (n-1) multipliers that define the matrix L from the*          LU factorization of A as computed by DGTTRF.**  DF      (input) DOUBLE PRECISION array, dimension (N)*          The n diagonal elements of the upper triangular matrix U from*          the LU factorization of A.**  DUF     (input) DOUBLE PRECISION array, dimension (N-1)*          The (n-1) elements of the first superdiagonal of U.**  DU2     (input) DOUBLE PRECISION array, dimension (N-2)*          The (n-2) elements of the second superdiagonal of U.**  IPIV    (input) INTEGER array, dimension (N)*          The pivot indices; for 1 <= i <= n, row i of the matrix was*          interchanged with row IPIV(i).  IPIV(i) will always be either*          i or i+1; IPIV(i) = i indicates a row interchange was not*          required.**  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)*          The right hand side matrix B.**  LDB     (input) INTEGER*          The leading dimension of the array B.  LDB >= max(1,N).**  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)*          On entry, the solution matrix X, as computed by DGTTRS.*          On exit, the improved solution matrix X.**  LDX     (input) INTEGER*          The leading dimension of the array X.  LDX >= max(1,N).**  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)*          The estimated forward error bound for each solution vector*          X(j) (the j-th column of the solution matrix X).*          If XTRUE is the true solution corresponding to X(j), FERR(j)*          is an estimated upper bound for the magnitude of the largest*          element in (X(j) - XTRUE) divided by the magnitude of the*          largest element in X(j).  The estimate is as reliable as*          the estimate for RCOND, and is almost always a slight*          overestimate of the true error.**  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)*          The componentwise relative backward error of each solution*          vector X(j) (i.e., the smallest relative change in*          any element of A or B that makes X(j) an exact solution).**  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)**  IWORK   (workspace) INTEGER array, dimension (N)**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value**  Internal Parameters*  ===================**  ITMAX is the maximum number of steps of iterative refinement.**  =====================================================================**     .. Parameters ..      INTEGER            ITMAX      PARAMETER          ( ITMAX = 5 )      DOUBLE PRECISION   ZERO, ONE      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )      DOUBLE PRECISION   TWO      PARAMETER          ( TWO = 2.0D+0 )      DOUBLE PRECISION   THREE      PARAMETER          ( THREE = 3.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            NOTRAN      CHARACTER          TRANSN, TRANST      INTEGER            COUNT, I, J, KASE, NZ      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN*     ..*     .. External Subroutines ..      EXTERNAL           DAXPY, DCOPY, DGTTRS, DLACON, DLAGTM, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX*     ..*     .. External Functions ..      LOGICAL            LSAME      DOUBLE PRECISION   DLAMCH      EXTERNAL           LSAME, DLAMCH*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0      NOTRAN = LSAME( TRANS, 'N
' )      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T
' ) .AND. .NOT.     $    LSAME( TRANS, 'C











' ) ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( NRHS.LT.0 ) THEN         INFO = -3      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN         INFO = -13      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN         INFO = -15      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGTRFS














', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN         DO 10 J = 1, NRHS            FERR( J ) = ZERO            BERR( J ) = ZERO   10    CONTINUE         RETURN      END IF*      IF( NOTRAN ) THEN         TRANSN = 'N
'         TRANST = 'T

'      ELSE         TRANSN = 'T
'         TRANST = 'N





'      END IF**     NZ = maximum number of nonzero elements in each row of A, plus 1*      NZ = 4      EPS = DLAMCH( 'Epsilon
' )      SAFMIN = DLAMCH( 'Safe minimum

































































































































































































' )      SAFE1 = NZ*SAFMIN      SAFE2 = SAFE1 / EPS**     Do for each right hand side*      DO 110 J = 1, NRHS*         COUNT = 1         LSTRES = THREE   20    CONTINUE**        Loop until stopping criterion is satisfied.**        Compute residual R = B - op(A) * X,*        where op(A) = A, A**T, or A**H, depending on TRANS.*         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )         CALL DLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,     $                WORK( N+1 ), N )**        Compute abs(op(A))*abs(x) + abs(b) for use in the backward*        error bound.*         IF( NOTRAN ) THEN            IF( N.EQ.1 ) THEN               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )            ELSE               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +     $                     ABS( DU( 1 )*X( 2, J ) )               DO 30 I = 2, N - 1                  WORK( I ) = ABS( B( I, J ) ) +     $                        ABS( DL( I-1 )*X( I-1, J ) ) +     $                        ABS( D( I )*X( I, J ) ) +     $                        ABS( DU( I )*X( I+1, J ) )   30          CONTINUE               WORK( N ) = ABS( B( N, J ) ) +     $                     ABS( DL( N-1 )*X( N-1, J ) ) +     $                     ABS( D( N )*X( N, J ) )            END IF         ELSE            IF( N.EQ.1 ) THEN               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )            ELSE               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +     $                     ABS( DL( 1 )*X( 2, J ) )               DO 40 I = 2, N - 1                  WORK( I ) = ABS( B( I, J ) ) +     $                        ABS( DU( I-1 )*X( I-1, J ) ) +     $                        ABS( D( I )*X( I, J ) ) +     $                        ABS( DL( I )*X( I+1, J ) )   40          CONTINUE               WORK( N ) = ABS( B( N, J ) ) +     $                     ABS( DU( N-1 )*X( N-1, J ) ) +     $                     ABS( D( N )*X( N, J ) )            END IF         END IF**        Compute componentwise relative backward error from formula**        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )**        where abs(Z) is the componentwise absolute value of the matrix*        or vector Z.  If the i-th component of the denominator is less*        than SAFE2, then SAFE1 is added to the i-th components of the*        numerator and denominator before dividing.*         S = ZERO         DO 50 I = 1, N            IF( WORK( I ).GT.SAFE2 ) THEN               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )            ELSE               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /     $             ( WORK( I )+SAFE1 ) )            END IF   50    CONTINUE         BERR( J ) = S**        Test stopping criterion. Continue iterating if*           1) The residual BERR(J) is larger than machine epsilon, and*           2) BERR(J) decreased by at least a factor of 2 during the*              last iteration, and*           3) At most ITMAX iterations tried.*         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.     $       COUNT.LE.ITMAX ) THEN**           Update solution and try again.*            CALL DGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV,     $                   WORK( N+1 ), N, INFO )            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )            LSTRES = BERR( J )            COUNT = COUNT + 1            GO TO 20         END IF**        Bound error from formula**        norm(X - XTRUE) / norm(X) .le. FERR =*        norm( abs(inv(op(A)))**           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)**        where*          norm(Z) is the magnitude of the largest component of Z*          inv(op(A)) is the inverse of op(A)*          abs(Z) is the componentwise absolute value of the matrix or*             vector Z*          NZ is the maximum number of nonzeros in any row of A, plus 1*          EPS is machine epsilon**        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))*        is incremented by SAFE1 if the i-th component of*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.**        Use DLACON to estimate the infinity-norm of the matrix*           inv(op(A)) * diag(W),*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))*         DO 60 I = 1, N            IF( WORK( I ).GT.SAFE2 ) THEN               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )            ELSE               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1            END IF   60    CONTINUE*         KASE = 0   70    CONTINUE         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),     $                KASE )         IF( KASE.NE.0 ) THEN            IF( KASE.EQ.1 ) THEN**              Multiply by diag(W)*inv(op(A)**T).*               CALL DGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV,     $                      WORK( N+1 ), N, INFO )               DO 80 I = 1, N                  WORK( N+I ) = WORK( I )*WORK( N+I )   80          CONTINUE            ELSE**              Multiply by inv(op(A))*diag(W).*               DO 90 I = 1, N                  WORK( N+I ) = WORK( I )*WORK( N+I )   90          CONTINUE               CALL DGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV,     $                      WORK( N+1 ), N, INFO )            END IF            GO TO 70         END IF**        Normalize error.*         LSTRES = ZERO         DO 100 I = 1, N            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )  100    CONTINUE         IF( LSTRES.NE.ZERO )     $      FERR( J ) = FERR( J ) / LSTRES*  110 CONTINUE*      RETURN**     End of DGTRFS*      END      SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     October 31, 1999**     .. Scalar Arguments ..      INTEGER            INFO, LDB, N, NRHS*     ..*     .. Array Arguments ..      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * )*     ..**  Purpose*  =======**  DGTSV  solves the equation**     A*X = B,**  where A is an n by n tridiagonal matrix, by Gaussian elimination with*  partial pivoting.**  Note that the equation  A'*X = B  may be solved by interchanging the
*  order of the arguments DU and DL.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  DL      (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On entry, DL must contain the (n-1) sub-diagonal elements of
*          A.
*
*          On exit, DL is overwritten by the (n-2) elements of the
*          second super-diagonal of the upper triangular matrix U from
*          the LU factorization of A, in DL(1), ..., DL(n-2).
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, D must contain the diagonal elements of A.
*
*          On exit, D is overwritten by the n diagonal elements of U.
*
*  DU      (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On entry, DU must contain the (n-1) super-diagonal elements
*          of A.
*
*          On exit, DU is overwritten by the (n-1) elements of the first
*          super-diagonal of U.
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the N by NRHS matrix of right hand side matrix B.
*          On exit, if INFO = 0, the N by NRHS solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          > 0: if INFO = i, U(i,i) is exactly zero, and the solution
*               has not been computed.  The factorization has not been
*               completed unless i = N.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   FACT, TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTSV ', -INFO )
         RETURN
      END IF
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( NRHS.EQ.1 ) THEN
         DO 10 I = 1, N - 2
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
*              No row interchange required
*
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
               ELSE
                  INFO = I
                  RETURN
               END IF
               DL( I ) = ZERO
            ELSE
*
*              Interchange rows I and I+1
*
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DL( I ) = DU( I+1 )
               DU( I+1 ) = -FACT*DL( I )
               DU( I ) = TEMP
               TEMP = B( I, 1 )
               B( I, 1 ) = B( I+1, 1 )
               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
            END IF
   10    CONTINUE
         IF( N.GT.1 ) THEN
            I = N - 1
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
               ELSE
                  INFO = I
                  RETURN
               END IF
            ELSE
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DU( I ) = TEMP
               TEMP = B( I, 1 )
               B( I, 1 ) = B( I+1, 1 )
               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
            END IF
         END IF
         IF( D( N ).EQ.ZERO ) THEN
            INFO = N
            RETURN
         END IF
      ELSE
         DO 40 I = 1, N - 2
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
*              No row interchange required
*
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  DO 20 J = 1, NRHS
                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
   20             CONTINUE
               ELSE
                  INFO = I
                  RETURN
               END IF
               DL( I ) = ZERO
            ELSE
*
*              Interchange rows I and I+1
*
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DL( I ) = DU( I+1 )
               DU( I+1 ) = -FACT*DL( I )
               DU( I ) = TEMP
               DO 30 J = 1, NRHS
                  TEMP = B( I, J )
                  B( I, J ) = B( I+1, J )
                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
   30          CONTINUE
            END IF
   40    CONTINUE
         IF( N.GT.1 ) THEN
            I = N - 1
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  DO 50 J = 1, NRHS
                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
   50             CONTINUE
               ELSE
                  INFO = I
                  RETURN
               END IF
            ELSE
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DU( I ) = TEMP
               DO 60 J = 1, NRHS
                  TEMP = B( I, J )
                  B( I, J ) = B( I+1, J )
                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
   60          CONTINUE
            END IF
         END IF
         IF( D( N ).EQ.ZERO ) THEN
            INFO = N
            RETURN
         END IF
      END IF
*
*     Back solve with the matrix U from the factorization.
*
      IF( NRHS.LE.2 ) THEN
         J = 1
   70    CONTINUE
         B( N, J ) = B( N, J ) / D( N )
         IF( N.GT.1 )
     $      B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
         DO 80 I = N - 2, 1, -1
            B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
     $                  B( I+2, J ) ) / D( I )
   80    CONTINUE
         IF( J.LT.NRHS ) THEN
            J = J + 1
            GO TO 70
         END IF
      ELSE
         DO 100 J = 1, NRHS
            B( N, J ) = B( N, J ) / D( N )
            IF( N.GT.1 )
     $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
     $                       D( N-1 )
            DO 90 I = N - 2, 1, -1
               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
     $                     B( I+2, J ) ) / D( I )
   90       CONTINUE
  100    CONTINUE
      END IF
*
      RETURN
*
*     End of DGTSV
*
      END
      SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
     $                   DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
     $                   WORK, IWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          FACT, TRANS
      INTEGER            INFO, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
     $                   DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
     $                   FERR( * ), WORK( * ), X( LDX, * )
*     ..
*
*  Purpose
*  =======
*
*  DGTSVX uses the LU factorization to compute the solution to a real
*  system of linear equations A * X = B or A**T * X = B,
*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
*  matrices.
*
*  Error bounds on the solution and a condition estimate are also
*  provided.
*
*  Description
*  ===========
*
*  The following steps are performed:
*
*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A
*     as A = L * U, where L is a product of permutation and unit lower
*     bidiagonal matrices and U is upper triangular with nonzeros in
*     only the main diagonal and first two superdiagonals.
*
*  2. If some U(i,i)=0, so that U is exactly singular, then the routine
*     returns with INFO = i. Otherwise, the factored form of A is used
*     to estimate the condition number of the matrix A.  If the
*     reciprocal of the condition number is less than machine precision,
*     INFO = N+1 is returned as a warning, but the routine still goes on
*     to solve for X and compute error bounds as described below.
*
*  3. The system of equations is solved for X using the factored form
*     of A.
*
*  4. Iterative refinement is applied to improve the computed solution
*     matrix and calculate error bounds and backward error estimates
*     for it.
*
*  Arguments
*  =========
*
*  FACT    (input) CHARACTER*1
*          Specifies whether or not the factored form of A has been
*          supplied on entry.
*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored
*                  form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
*                  will not be modified.
*          = 'N':  The matrix will be copied to DLF, DF, and DUF
*                  and factored.
*
*  TRANS   (input) CHARACTER*1
*          Specifies the form of the system of equations:
*          = 'N':  A * X = B     (No transpose)
*          = 'T':  A**T * X = B  (Transpose)
*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  DL      (input) DOUBLE PRECISION array, dimension (N-1)
*          The (n-1) subdiagonal elements of A.
*
*  D       (input) DOUBLE PRECISION array, dimension (N)
*          The n diagonal elements of A.
*
*  DU      (input) DOUBLE PRECISION array, dimension (N-1)
*          The (n-1) superdiagonal elements of A.
*
*  DLF     (input or output) DOUBLE PRECISION array, dimension (N-1)
*          If FACT = 'F', then DLF is an input argument and on entry
*          contains the (n-1) multipliers that define the matrix L from
*          the LU factorization of A as computed by DGTTRF.
*
*          If FACT = 'N', then DLF is an output argument and on exit
*          contains the (n-1) multipliers that define the matrix L from
*          the LU factorization of A.
*
*  DF      (input or output) DOUBLE PRECISION array, dimension (N)
*          If FACT = 'F', then DF is an input argument and on entry
*          contains the n diagonal elements of the upper triangular
*          matrix U from the LU factorization of A.
*
*          If FACT = 'N', then DF is an output argument and on exit
*          contains the n diagonal elements of the upper triangular
*          matrix U from the LU factorization of A.
*
*  DUF     (input or output) DOUBLE PRECISION array, dimension (N-1)
*          If FACT = 'F', then DUF is an input argument and on entry
*          contains the (n-1) elements of the first superdiagonal of U.
*
*          If FACT = 'N', then DUF is an output argument and on exit
*          contains the (n-1) elements of the first superdiagonal of U.
*
*  DU2     (input or output) DOUBLE PRECISION array, dimension (N-2)
*          If FACT = 'F', then DU2 is an input argument and on entry
*          contains the (n-2) elements of the second superdiagonal of
*          U.
*
*          If FACT = 'N', then DU2 is an output argument and on exit
*          contains the (n-2) elements of the second superdiagonal of
*          U.
*
*  IPIV    (input or output) INTEGER array, dimension (N)
*          If FACT = 'F', then IPIV is an input argument and on entry
*          contains the pivot indices from the LU factorization of A as
*          computed by DGTTRF.
*
*          If FACT = 'N', then IPIV is an output argument and on exit
*          contains the pivot indices from the LU factorization of A;
*          row i of the matrix was interchanged with row IPIV(i).
*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
*          a row interchange was not required.
*
*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          The N-by-NRHS right hand side matrix B.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
*
*  LDX     (input) INTEGER
*          The leading dimension of the array X.  LDX >= max(1,N).
*
*  RCOND   (output) DOUBLE PRECISION
*          The estimate of the reciprocal condition number of the matrix
*          A.  If RCOND is less than the machine precision (in
*          particular, if RCOND = 0), the matrix is singular to working
*          precision.  This condition is indicated by a return code of
*          INFO > 0.
*
*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
*          The estimated forward error bound for each solution vector
*          X(j) (the j-th column of the solution matrix X).
*          If XTRUE is the true solution corresponding to X(j), FERR(j)
*          is an estimated upper bound for the magnitude of the largest
*          element in (X(j) - XTRUE) divided by the magnitude of the
*          largest element in X(j).  The estimate is as reliable as
*          the estimate for RCOND, and is almost always a slight
*          overestimate of the true error.
*
*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
*          The componentwise relative backward error of each solution
*          vector X(j) (i.e., the smallest relative change in
*          any element of A or B that makes X(j) an exact solution).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
*
*  IWORK   (workspace) INTEGER array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, and i is
*                <= N:  U(i,i) is exactly zero.  The factorization
*                       has not been completed unless i = N, but the
*                       factor U is exactly singular, so the solution
*                       and error bounds could not be computed.
*                       RCOND = 0 is returned.
*                = N+1: U is nonsingular, but RCOND is less than machine
*                       precision, meaning that the matrix is singular
*                       to working precision.  Nevertheless, the
*                       solution and error bounds are computed because
*                       there are a number of situations where the
*                       computed solution can be more accurate than the
*                       value of RCOND would suggest.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOFACT, NOTRAN
      CHARACTER          NORM
      DOUBLE PRECISION   ANORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGT
      EXTERNAL           LSAME, DLAMCH, DLANGT
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $         LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTSVX', -INFO )
         RETURN
      END IF
*
      IF( NOFACT ) THEN
*
*        Compute the LU factorization of A.
*
         CALL DCOPY( N, D, 1, DF, 1 )
         IF( N.GT.1 ) THEN
            CALL DCOPY( N-1, DL, 1, DLF, 1 )
            CALL DCOPY( N-1, DU, 1, DUF, 1 )
         END IF
         CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
*
*        Return if INFO is non-zero.
*
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 )
     $         RCOND = ZERO
            RETURN
         END IF
      END IF
*
*     Compute the norm of the matrix A.
*
      IF( NOTRAN ) THEN
         NORM = '1'
      ELSE
         NORM = 'I'
      END IF
      ANORM = DLANGT( NORM, N, DL, D, DU )
*
*     Compute the reciprocal of the condition number of A.
*
      CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
     $             IWORK, INFO )
*
*     Set INFO = N+1 if the matrix is singular to working precision.
*
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
     $   INFO = N + 1
*
*     Compute the solution vectors X.
*
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
     $             INFO )
*
*     Use iterative refinement to improve the computed solutions and
*     compute error bounds and backward error estimates for them.
*
      CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
     $             B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
*
      RETURN
*
*     End of DGTSVX
*
      END
      SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   D( * ), DL( * ), DU( * ), DU2( * )
*     ..
*
*  Purpose
*  =======
*
*  DGTTRF computes an LU factorization of a real tridiagonal matrix A
*  using elimination with partial pivoting and row interchanges.
*
*  The factorization has the form
*     A = L * U
*  where L is a product of permutation and unit lower bidiagonal
*  matrices and U is upper triangular with nonzeros in only the main
*  diagonal and first two superdiagonals.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.
*
*  DL      (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On entry, DL must contain the (n-1) sub-diagonal elements of
*          A.
*
*          On exit, DL is overwritten by the (n-1) multipliers that
*          define the matrix L from the LU factorization of A.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, D must contain the diagonal elements of A.
*
*          On exit, D is overwritten by the n diagonal elements of the
*          upper triangular matrix U from the LU factorization of A.
*
*  DU      (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On entry, DU must contain the (n-1) super-diagonal elements
*          of A.
*
*          On exit, DU is overwritten by the (n-1) elements of the first
*          super-diagonal of U.
*
*  DU2     (output) DOUBLE PRECISION array, dimension (N-2)
*          On exit, DU2 is overwritten by the (n-2) elements of the
*          second super-diagonal of U.
*
*  IPIV    (output) INTEGER array, dimension (N)
*          The pivot indices; for 1 <= i <= n, row i of the matrix was
*          interchanged with row IPIV(i).  IPIV(i) will always be either
*          i or i+1; IPIV(i) = i indicates a row interchange was not
*          required.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -k, the k-th argument had an illegal value
*          > 0:  if INFO = k, U(k,k) is exactly zero. The factorization
*                has been completed, but the factor U is exactly
*                singular, and division by zero will occur if it is used
*                to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   FACT, TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DGTTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Initialize IPIV(i) = i and DU2(I) = 0
*
      DO 10 I = 1, N
         IPIV( I ) = I
   10 CONTINUE
      DO 20 I = 1, N - 2
         DU2( I ) = ZERO
   20 CONTINUE
*
      DO 30 I = 1, N - 2
         IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
*           No row interchange required, eliminate DL(I)
*
            IF( D( I ).NE.ZERO ) THEN
               FACT = DL( I ) / D( I )
               DL( I ) = FACT
               D( I+1 ) = D( I+1 ) - FACT*DU( I )
            END IF
         ELSE
*
*           Interchange rows I and I+1, eliminate DL(I)
*
            FACT = D( I ) / DL( I )
            D( I ) = DL( I )
            DL( I ) = FACT
            TEMP = DU( I )
            DU( I ) = D( I+1 )
            D( I+1 ) = TEMP - FACT*D( I+1 )
            DU2( I ) = DU( I+1 )
            DU( I+1 ) = -FACT*DU( I+1 )
            IPIV( I ) = I + 1
         END IF
   30 CONTINUE
      IF( N.GT.1 ) THEN
         I = N - 1
         IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
            IF( D( I ).NE.ZERO ) THEN
               FACT = DL( I ) / D( I )
               DL( I ) = FACT
               D( I+1 ) = D( I+1 ) - FACT*DU( I )
            END IF
         ELSE
            FACT = D( I ) / DL( I )
            D( I ) = DL( I )
            DL( I ) = FACT
            TEMP = DU( I )
            DU( I ) = D( I+1 )
            D( I+1 ) = TEMP - FACT*D( I+1 )
            IPIV( I ) = I + 1
         END IF
      END IF
*
*     Check for a zero on the diagonal of U.
*
      DO 40 I = 1, N
         IF( D( I ).EQ.ZERO ) THEN
            INFO = I
            GO TO 50
         END IF
   40 CONTINUE
   50 CONTINUE
*
      RETURN
*
*     End of DGTTRF
*
      END
      SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB,
     $                   INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
*     ..
*
*  Purpose
*  =======
*
*  DGTTRS solves one of the systems of equations
*     A*X = B  or  A








'*X = B,*  with a tridiagonal matrix A using the LU factorization computed*  by DGTTRF.**  Arguments*  =========**  TRANS   (input) CHARACTER*          Specifies the form of the system of equations.*          = 'N
':  A * X = B  (No transpose)*          = 'T':  A'* X = B  (Transpose)
*          = 'C':  A


























































'* X = B  (Conjugate transpose = Transpose)**  N       (input) INTEGER*          The order of the matrix A.**  NRHS    (input) INTEGER*          The number of right hand sides, i.e., the number of columns*          of the matrix B.  NRHS >= 0.**  DL      (input) DOUBLE PRECISION array, dimension (N-1)*          The (n-1) multipliers that define the matrix L from the*          LU factorization of A.**  D       (input) DOUBLE PRECISION array, dimension (N)*          The n diagonal elements of the upper triangular matrix U from*          the LU factorization of A.**  DU      (input) DOUBLE PRECISION array, dimension (N-1)*          The (n-1) elements of the first super-diagonal of U.**  DU2     (input) DOUBLE PRECISION array, dimension (N-2)*          The (n-2) elements of the second super-diagonal of U.**  IPIV    (input) INTEGER array, dimension (N)*          The pivot indices; for 1 <= i <= n, row i of the matrix was*          interchanged with row IPIV(i).  IPIV(i) will always be either*          i or i+1; IPIV(i) = i indicates a row interchange was not*          required.**  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)*          On entry, the matrix of right hand side vectors B.*          On exit, B is overwritten by the solution vectors X.**  LDB     (input) INTEGER*          The leading dimension of the array B.  LDB >= max(1,N).**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value**  =====================================================================**     .. Local Scalars ..      LOGICAL            NOTRAN      INTEGER            ITRANS, J, JB, NB*     ..*     .. External Functions ..      INTEGER            ILAENV      EXTERNAL           ILAENV*     ..*     .. External Subroutines ..      EXTERNAL           DGTTS2, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..*      INFO = 0      NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n
' )      IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T
' .OR. TRANS.EQ.     $    't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c









' ) ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( NRHS.LT.0 ) THEN         INFO = -3      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN         INFO = -10      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DGTTRS





















', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 .OR. NRHS.EQ.0 )     $   RETURN**     Decode TRANS*      IF( NOTRAN ) THEN         ITRANS = 0      ELSE         ITRANS = 1      END IF**     Determine the number of right-hand sides to solve at a time.*      IF( NRHS.EQ.1 ) THEN         NB = 1      ELSE         NB = MAX( 1, ILAENV( 1, 'DGTTRS


















































', TRANS, N, NRHS, -1, -1 ) )      END IF*      IF( NB.GE.NRHS ) THEN         CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )      ELSE         DO 10 J = 1, NRHS, NB            JB = MIN( NRHS-J+1, NB )            CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),     $                   LDB )   10    CONTINUE      END IF**     End of DGTTRS*      END      SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB,     $                   ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,     $                   LWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      CHARACTER          COMPQ, COMPZ, JOB      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),     $                   B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ),     $                   Z( LDZ, * )*     ..**  Purpose*  =======**  DHGEQZ implements a single-/double-shift version of the QZ method for*  finding the generalized eigenvalues**  w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j)   of the equation**       det( A - w(i) B ) = 0**  In addition, the pair A,B may be reduced to generalized Schur form:*  B is upper triangular, and A is block upper triangular, where the*  diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having*  complex generalized eigenvalues (see the description of the argument*  JOB.)**  If JOB='S







', then the pair (A,B) is simultaneously reduced to Schur*  form by applying one orthogonal tranformation (usually called Q) on*  the left and another (usually called Z) on the right.  The 2-by-2*  upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks*  of A will be reduced to positive diagonal matrices.  (I.e.,*  if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and*  B(j+1,j+1) will be positive.)**  If JOB='E



', then at each iteration, the same transformations*  are computed, but they are only applied to those parts of A and B*  which are needed to compute ALPHAR, ALPHAI, and BETAR.**  If JOB='S' and COMPQ and COMPZ are 'V' or 'I














', then the orthogonal*  transformations used to reduce (A,B) are accumulated into the arrays*  Q and Z s.t.:**       Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)**       Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)***  Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix*       Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),*       pp. 241--256.**  Arguments*  =========**  JOB     (input) CHARACTER*1*          = 'E

': compute only ALPHAR, ALPHAI, and BETA.  A and B will*                 not necessarily be put into generalized Schur form.*          = 'S



': put A and B into generalized Schur form, as well*                 as computing ALPHAR, ALPHAI, and BETA.**  COMPQ   (input) CHARACTER*1*          = 'N
': do not modify Q.*          = 'V


': multiply the array Q on the right by the transpose of*                 the orthogonal tranformation that is applied to the*                 left side of A and B to reduce them to Schur form.*          = 'I': like COMPQ='V



', except that Q will be initialized to*                 the identity first.**  COMPZ   (input) CHARACTER*1*          = 'N
': do not modify Z.*          = 'V


': multiply the array Z on the right by the orthogonal*                 tranformation that is applied to the right side of*                 A and B to reduce them to Schur form.*          = 'I': like COMPZ='V














', except that Z will be initialized to*                 the identity first.**  N       (input) INTEGER*          The order of the matrices A, B, Q, and Z.  N >= 0.**  ILO     (input) INTEGER*  IHI     (input) INTEGER*          It is assumed that A is already upper triangular in rows and*          columns 1:ILO-1 and IHI+1:N.*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.**  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)*          On entry, the N-by-N upper Hessenberg matrix A.  Elements*          below the subdiagonal must be zero.*          If JOB='S

', then on exit A and B will have been*             simultaneously reduced to generalized Schur form.*          If JOB='E













', then on exit A will have been destroyed.*             The diagonal blocks will be correct, but the off-diagonal*             portion will be meaningless.**  LDA     (input) INTEGER*          The leading dimension of the array A.  LDA >= max( 1, N ).**  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)*          On entry, the N-by-N upper triangular matrix B.  Elements*          below the diagonal must be zero.  2-by-2 blocks in B*          corresponding to 2-by-2 blocks in A will be reduced to*          positive diagonal form.  (I.e., if A(j+1,j) is non-zero,*          then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be*          positive.)*          If JOB='S

', then on exit A and B will have been*             simultaneously reduced to Schur form.*          If JOB='E










































', then on exit B will have been destroyed.*             Elements corresponding to diagonal blocks of A will be*             correct, but the off-diagonal portion will be meaningless.**  LDB     (input) INTEGER*          The leading dimension of the array B.  LDB >= max( 1, N ).**  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)*          ALPHAR(1:N) will be set to real parts of the diagonal*          elements of A that would result from reducing A and B to*          Schur form and then further reducing them both to triangular*          form using unitary transformations s.t. the diagonal of B*          was non-negative real.  Thus, if A(j,j) is in a 1-by-1 block*          (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j).*          Note that the (real or complex) values*          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the*          generalized eigenvalues of the matrix pencil A - wB.**  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)*          ALPHAI(1:N) will be set to imaginary parts of the diagonal*          elements of A that would result from reducing A and B to*          Schur form and then further reducing them both to triangular*          form using unitary transformations s.t. the diagonal of B*          was non-negative real.  Thus, if A(j,j) is in a 1-by-1 block*          (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0.*          Note that the (real or complex) values*          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the*          generalized eigenvalues of the matrix pencil A - wB.**  BETA    (output) DOUBLE PRECISION array, dimension (N)*          BETA(1:N) will be set to the (real) diagonal elements of B*          that would result from reducing A and B to Schur form and*          then further reducing them both to triangular form using*          unitary transformations s.t. the diagonal of B was*          non-negative real.  Thus, if A(j,j) is in a 1-by-1 block*          (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j).*          Note that the (real or complex) values*          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the*          generalized eigenvalues of the matrix pencil A - wB.*          (Note that BETA(1:N) will always be non-negative, and no*          BETAI is necessary.)**  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)*          If COMPQ='N
', then Q will not be referenced.*          If COMPQ='V' or 'I





', then the transpose of the orthogonal*             transformations which are applied to A and B on the left*             will be applied to the array Q on the right.**  LDQ     (input) INTEGER*          The leading dimension of the array Q.  LDQ >= 1.*          If COMPQ='V' or 'I


', then LDQ >= N.**  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)*          If COMPZ='N
', then Z will not be referenced.*          If COMPZ='V' or 'I





', then the orthogonal transformations*             which are applied to A and B on the right will be applied*             to the array Z on the right.**  LDZ     (input) INTEGER*          The leading dimension of the array Z.  LDZ >= 1.*          If COMPZ='V' or 'I













































































', then LDZ >= N.**  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)*          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.**  LWORK   (input) INTEGER*          The dimension of the array WORK.  LWORK >= max(1,N).**          If LWORK = -1, then a workspace query is assumed; the routine*          only calculates the optimal size of the WORK array, returns*          this value as the first entry of the WORK array, and no error*          message related to LWORK is issued by XERBLA.**  INFO    (output) INTEGER*          = 0: successful exit*          < 0: if INFO = -i, the i-th argument had an illegal value*          = 1,...,N: the QZ iteration did not converge.  (A,B) is not*                     in Schur form, but ALPHAR(i), ALPHAI(i), and*                     BETA(i), i=INFO+1,...,N should be correct.*          = N+1,...,2*N: the shift calculation failed.  (A,B) is not*                     in Schur form, but ALPHAR(i), ALPHAI(i), and*                     BETA(i), i=INFO-N+1,...,N should be correct.*          > 2*N:     various "impossible" errors.**  Further Details*  ===============**  Iteration counters:**  JITER  -- counts iterations.*  IITER  -- counts iterations run since ILAST was last*            changed.  This is therefore reset only when a 1-by-1 or*            2-by-2 block deflates off the bottom.**  =====================================================================**     .. Parameters ..*    $                     SAFETY = 1.0E+0 )      DOUBLE PRECISION   HALF, ZERO, ONE, SAFETY      PARAMETER          ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0,     $                   SAFETY = 1.0D+2 )*     ..*     .. Local Scalars ..      LOGICAL            ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,     $                   LQUERY      INTEGER            ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,     $                   ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,     $                   JR, MAXIT      DOUBLE PRECISION   A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,     $                   AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,     $                   AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,     $                   B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,     $                   BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,     $                   CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,     $                   SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T,     $                   TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,     $                   U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,     $                   WR2*     ..*     .. Local Arrays ..      DOUBLE PRECISION   V( 3 )*     ..*     .. External Functions ..      LOGICAL            LSAME      DOUBLE PRECISION   DLAMCH, DLANHS, DLAPY2, DLAPY3      EXTERNAL           LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3*     ..*     .. External Subroutines ..      EXTERNAL           DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT,     $                   XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT*     ..*     .. Executable Statements ..**     Decode JOB, COMPQ, COMPZ*      IF( LSAME( JOB, 'E


' ) ) THEN         ILSCHR = .FALSE.         ISCHUR = 1      ELSE IF( LSAME( JOB, 'S






' ) ) THEN         ILSCHR = .TRUE.         ISCHUR = 2      ELSE         ISCHUR = 0      END IF*      IF( LSAME( COMPQ, 'N


' ) ) THEN         ILQ = .FALSE.         ICOMPQ = 1      ELSE IF( LSAME( COMPQ, 'V


' ) ) THEN         ILQ = .TRUE.         ICOMPQ = 2      ELSE IF( LSAME( COMPQ, 'I






' ) ) THEN         ILQ = .TRUE.         ICOMPQ = 3      ELSE         ICOMPQ = 0      END IF*      IF( LSAME( COMPZ, 'N


' ) ) THEN         ILZ = .FALSE.         ICOMPZ = 1      ELSE IF( LSAME( COMPZ, 'V


' ) ) THEN         ILZ = .TRUE.         ICOMPZ = 2      ELSE IF( LSAME( COMPZ, 'I



































' ) ) THEN         ILZ = .TRUE.         ICOMPZ = 3      ELSE         ICOMPZ = 0      END IF**     Check Argument Values*      INFO = 0      WORK( 1 ) = MAX( 1, N )      LQUERY = ( LWORK.EQ.-1 )      IF( ISCHUR.EQ.0 ) THEN         INFO = -1      ELSE IF( ICOMPQ.EQ.0 ) THEN         INFO = -2      ELSE IF( ICOMPZ.EQ.0 ) THEN         INFO = -3      ELSE IF( N.LT.0 ) THEN         INFO = -4      ELSE IF( ILO.LT.1 ) THEN         INFO = -5      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN         INFO = -6      ELSE IF( LDA.LT.N ) THEN         INFO = -8      ELSE IF( LDB.LT.N ) THEN         INFO = -10      ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN         INFO = -15      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN         INFO = -17      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN         INFO = -19      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DHGEQZ















', -INFO )         RETURN      ELSE IF( LQUERY ) THEN         RETURN      END IF**     Quick return if possible*      IF( N.LE.0 ) THEN         WORK( 1 ) = DBLE( 1 )         RETURN      END IF**     Initialize Q and Z*      IF( ICOMPQ.EQ.3 )     $   CALL DLASET( 'Full

', N, N, ZERO, ONE, Q, LDQ )      IF( ICOMPZ.EQ.3 )     $   CALL DLASET( 'Full




', N, N, ZERO, ONE, Z, LDZ )**     Machine Constants*      IN = IHI + 1 - ILO      SAFMIN = DLAMCH( 'S

' )      SAFMAX = ONE / SAFMIN      ULP = DLAMCH( 'E' )*DLAMCH( 'B
' )      ANORM = DLANHS( 'F
', IN, A( ILO, ILO ), LDA, WORK )      BNORM = DLANHS( 'F








































































































































































































































































































































































































































































































































































































































































































































































































































































































































































', IN, B( ILO, ILO ), LDB, WORK )      ATOL = MAX( SAFMIN, ULP*ANORM )      BTOL = MAX( SAFMIN, ULP*BNORM )      ASCALE = ONE / MAX( SAFMIN, ANORM )      BSCALE = ONE / MAX( SAFMIN, BNORM )**     Set Eigenvalues IHI+1:N*      DO 30 J = IHI + 1, N         IF( B( J, J ).LT.ZERO ) THEN            IF( ILSCHR ) THEN               DO 10 JR = 1, J                  A( JR, J ) = -A( JR, J )                  B( JR, J ) = -B( JR, J )   10          CONTINUE            ELSE               A( J, J ) = -A( J, J )               B( J, J ) = -B( J, J )            END IF            IF( ILZ ) THEN               DO 20 JR = 1, N                  Z( JR, J ) = -Z( JR, J )   20          CONTINUE            END IF         END IF         ALPHAR( J ) = A( J, J )         ALPHAI( J ) = ZERO         BETA( J ) = B( J, J )   30 CONTINUE**     If IHI < ILO, skip QZ steps*      IF( IHI.LT.ILO )     $   GO TO 380**     MAIN QZ ITERATION LOOP**     Initialize dynamic indices**     Eigenvalues ILAST+1:N have been found.*        Column operations modify rows IFRSTM:whatever.*        Row operations modify columns whatever:ILASTM.**     If only eigenvalues are being computed, then*        IFRSTM is the row of the last splitting row above row ILAST;*        this is always at least ILO.*     IITER counts iterations since the last eigenvalue was found,*        to tell when to use an extraordinary shift.*     MAXIT is the maximum number of QZ sweeps allowed.*      ILAST = IHI      IF( ILSCHR ) THEN         IFRSTM = 1         ILASTM = N      ELSE         IFRSTM = ILO         ILASTM = IHI      END IF      IITER = 0      ESHIFT = ZERO      MAXIT = 30*( IHI-ILO+1 )*      DO 360 JITER = 1, MAXIT**        Split the matrix if possible.**        Two tests:*           1: A(j,j-1)=0  or  j=ILO*           2: B(j,j)=0*         IF( ILAST.EQ.ILO ) THEN**           Special case: j=ILAST*            GO TO 80         ELSE            IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN               A( ILAST, ILAST-1 ) = ZERO               GO TO 80            END IF         END IF*         IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN            B( ILAST, ILAST ) = ZERO            GO TO 70         END IF**        General case: j<ILAST*         DO 60 J = ILAST - 1, ILO, -1**           Test 1: for A(j,j-1)=0 or j=ILO*            IF( J.EQ.ILO ) THEN               ILAZRO = .TRUE.            ELSE               IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN                  A( J, J-1 ) = ZERO                  ILAZRO = .TRUE.               ELSE                  ILAZRO = .FALSE.               END IF            END IF**           Test 2: for B(j,j)=0*            IF( ABS( B( J, J ) ).LT.BTOL ) THEN               B( J, J ) = ZERO**              Test 1a: Check for 2 consecutive small subdiagonals in A*               ILAZR2 = .FALSE.               IF( .NOT.ILAZRO ) THEN                  TEMP = ABS( A( J, J-1 ) )                  TEMP2 = ABS( A( J, J ) )                  TEMPR = MAX( TEMP, TEMP2 )                  IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN                     TEMP = TEMP / TEMPR                     TEMP2 = TEMP2 / TEMPR                  END IF                  IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2*     $                ( ASCALE*ATOL ) )ILAZR2 = .TRUE.               END IF**              If both tests pass (1 & 2), i.e., the leading diagonal*              element of B in the block is zero, split a 1x1 block off*              at the top. (I.e., at the J-th row/column) The leading*              diagonal element of the remainder can also be zero, so*              this may have to be done repeatedly.*               IF( ILAZRO .OR. ILAZR2 ) THEN                  DO 40 JCH = J, ILAST - 1                     TEMP = A( JCH, JCH )                     CALL DLARTG( TEMP, A( JCH+1, JCH ), C, S,     $                            A( JCH, JCH ) )                     A( JCH+1, JCH ) = ZERO                     CALL DROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA,     $                          A( JCH+1, JCH+1 ), LDA, C, S )                     CALL DROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB,     $                          B( JCH+1, JCH+1 ), LDB, C, S )                     IF( ILQ )     $                  CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,     $                             C, S )                     IF( ILAZR2 )     $                  A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C                     ILAZR2 = .FALSE.                     IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN                        IF( JCH+1.GE.ILAST ) THEN                           GO TO 80                        ELSE                           IFIRST = JCH + 1                           GO TO 110                        END IF                     END IF                     B( JCH+1, JCH+1 ) = ZERO   40             CONTINUE                  GO TO 70               ELSE**                 Only test 2 passed -- chase the zero to B(ILAST,ILAST)*                 Then process as in the case B(ILAST,ILAST)=0*                  DO 50 JCH = J, ILAST - 1                     TEMP = B( JCH, JCH+1 )                     CALL DLARTG( TEMP, B( JCH+1, JCH+1 ), C, S,     $                            B( JCH, JCH+1 ) )                     B( JCH+1, JCH+1 ) = ZERO                     IF( JCH.LT.ILASTM-1 )     $                  CALL DROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB,     $                             B( JCH+1, JCH+2 ), LDB, C, S )                     CALL DROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA,     $                          A( JCH+1, JCH-1 ), LDA, C, S )                     IF( ILQ )     $                  CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,     $                             C, S )                     TEMP = A( JCH+1, JCH )                     CALL DLARTG( TEMP, A( JCH+1, JCH-1 ), C, S,     $                            A( JCH+1, JCH ) )                     A( JCH+1, JCH-1 ) = ZERO                     CALL DROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1,     $                          A( IFRSTM, JCH-1 ), 1, C, S )                     CALL DROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1,     $                          B( IFRSTM, JCH-1 ), 1, C, S )                     IF( ILZ )     $                  CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1,     $                             C, S )   50             CONTINUE                  GO TO 70               END IF            ELSE IF( ILAZRO ) THEN**              Only test 1 passed -- work on J:ILAST*               IFIRST = J               GO TO 110            END IF**           Neither test passed -- try next J*   60    CONTINUE**        (Drop-through is "impossible")*         INFO = N + 1         GO TO 420**        B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a*        1x1 block.*   70    CONTINUE         TEMP = A( ILAST, ILAST )         CALL DLARTG( TEMP, A( ILAST, ILAST-1 ), C, S,     $                A( ILAST, ILAST ) )         A( ILAST, ILAST-1 ) = ZERO         CALL DROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1,     $              A( IFRSTM, ILAST-1 ), 1, C, S )         CALL DROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1,     $              B( IFRSTM, ILAST-1 ), 1, C, S )         IF( ILZ )     $      CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )**        A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI,*                              and BETA*   80    CONTINUE         IF( B( ILAST, ILAST ).LT.ZERO ) THEN            IF( ILSCHR ) THEN               DO 90 J = IFRSTM, ILAST                  A( J, ILAST ) = -A( J, ILAST )                  B( J, ILAST ) = -B( J, ILAST )   90          CONTINUE            ELSE               A( ILAST, ILAST ) = -A( ILAST, ILAST )               B( ILAST, ILAST ) = -B( ILAST, ILAST )            END IF            IF( ILZ ) THEN               DO 100 J = 1, N                  Z( J, ILAST ) = -Z( J, ILAST )  100          CONTINUE            END IF         END IF         ALPHAR( ILAST ) = A( ILAST, ILAST )         ALPHAI( ILAST ) = ZERO         BETA( ILAST ) = B( ILAST, ILAST )**        Go to next block -- exit if finished.*         ILAST = ILAST - 1         IF( ILAST.LT.ILO )     $      GO TO 380**        Reset counters*         IITER = 0         ESHIFT = ZERO         IF( .NOT.ILSCHR ) THEN            ILASTM = ILAST            IF( IFRSTM.GT.ILAST )     $         IFRSTM = ILO         END IF         GO TO 350**        QZ step**        This iteration only involves rows/columns IFIRST:ILAST. We*        assume IFIRST < ILAST, and that the diagonal of B is non-zero.*  110    CONTINUE         IITER = IITER + 1         IF( .NOT.ILSCHR ) THEN            IFRSTM = IFIRST         END IF**        Compute single shifts.**        At this point, IFIRST < ILAST, and the diagonal elements of*        B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in*        magnitude)*         IF( ( IITER / 10 )*10.EQ.IITER ) THEN**           Exceptional shift.  Chosen for no particularly good reason.*           (Single shift only.)*            IF( ( DBLE( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT.     $          ABS( B( ILAST-1, ILAST-1 ) ) ) THEN               ESHIFT = ESHIFT + A( ILAST-1, ILAST ) /     $                  B( ILAST-1, ILAST-1 )            ELSE               ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) )            END IF            S1 = ONE            WR = ESHIFT*         ELSE**           Shifts based on the generalized eigenvalues of the*           bottom-right 2x2 block of A and B. The first eigenvalue*           returned by DLAG2 is the Wilkinson shift (AEP p.512),*            CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA,     $                  B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1,     $                  S2, WR, WR2, WI )*            TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )            IF( WI.NE.ZERO )     $         GO TO 200         END IF**        Fiddle with shift to avoid overflow*         TEMP = MIN( ASCALE, ONE )*( HALF*SAFMAX )         IF( S1.GT.TEMP ) THEN            SCALE = TEMP / S1         ELSE            SCALE = ONE         END IF*         TEMP = MIN( BSCALE, ONE )*( HALF*SAFMAX )         IF( ABS( WR ).GT.TEMP )     $      SCALE = MIN( SCALE, TEMP / ABS( WR ) )         S1 = SCALE*S1         WR = SCALE*WR**        Now check for two consecutive small subdiagonals.*         DO 120 J = ILAST - 1, IFIRST + 1, -1            ISTART = J            TEMP = ABS( S1*A( J, J-1 ) )            TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) )            TEMPR = MAX( TEMP, TEMP2 )            IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN               TEMP = TEMP / TEMPR               TEMP2 = TEMP2 / TEMPR            END IF            IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )*     $          TEMP2 )GO TO 130  120    CONTINUE*         ISTART = IFIRST  130    CONTINUE**        Do an implicit single-shift QZ sweep.**        Initial Q*         TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART )         TEMP2 = S1*A( ISTART+1, ISTART )         CALL DLARTG( TEMP, TEMP2, C, S, TEMPR )**        Sweep*         DO 190 J = ISTART, ILAST - 1            IF( J.GT.ISTART ) THEN               TEMP = A( J, J-1 )               CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )               A( J+1, J-1 ) = ZERO            END IF*            DO 140 JC = J, ILASTM               TEMP = C*A( J, JC ) + S*A( J+1, JC )               A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC )               A( J, JC ) = TEMP               TEMP2 = C*B( J, JC ) + S*B( J+1, JC )               B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC )               B( J, JC ) = TEMP2  140       CONTINUE            IF( ILQ ) THEN               DO 150 JR = 1, N                  TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )                  Q( JR, J ) = TEMP  150          CONTINUE            END IF*            TEMP = B( J+1, J+1 )            CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )            B( J+1, J ) = ZERO*            DO 160 JR = IFRSTM, MIN( J+2, ILAST )               TEMP = C*A( JR, J+1 ) + S*A( JR, J )               A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J )               A( JR, J+1 ) = TEMP  160       CONTINUE            DO 170 JR = IFRSTM, J               TEMP = C*B( JR, J+1 ) + S*B( JR, J )               B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J )               B( JR, J+1 ) = TEMP  170       CONTINUE            IF( ILZ ) THEN               DO 180 JR = 1, N                  TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )                  Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )                  Z( JR, J+1 ) = TEMP  180          CONTINUE            END IF  190    CONTINUE*         GO TO 350**        Use Francis double-shift**        Note: the Francis double-shift should work with real shifts,*              but only if the block is at least 3x3.*              This code may break if this point is reached with*              a 2x2 block with real eigenvalues.*  200    CONTINUE         IF( IFIRST+1.EQ.ILAST ) THEN**           Special case -- 2x2 block with complex eigenvectors**           Step 1: Standardize, that is, rotate so that**                       ( B11  0  )*                   B = (         )  with B11 non-negative.*                       (  0  B22 )*            CALL DLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ),     $                   B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL )*            IF( B11.LT.ZERO ) THEN               CR = -CR               SR = -SR               B11 = -B11               B22 = -B22            END IF*            CALL DROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA,     $                 A( ILAST, ILAST-1 ), LDA, CL, SL )            CALL DROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1,     $                 A( IFRSTM, ILAST ), 1, CR, SR )*            IF( ILAST.LT.ILASTM )     $         CALL DROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB,     $                    B( ILAST, ILAST+1 ), LDA, CL, SL )            IF( IFRSTM.LT.ILAST-1 )     $         CALL DROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1,     $                    B( IFRSTM, ILAST ), 1, CR, SR )*            IF( ILQ )     $         CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL,     $                    SL )            IF( ILZ )     $         CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR,     $                    SR )*            B( ILAST-1, ILAST-1 ) = B11            B( ILAST-1, ILAST ) = ZERO            B( ILAST, ILAST-1 ) = ZERO            B( ILAST, ILAST ) = B22**           If B22 is negative, negate column ILAST*            IF( B22.LT.ZERO ) THEN               DO 210 J = IFRSTM, ILAST                  A( J, ILAST ) = -A( J, ILAST )                  B( J, ILAST ) = -B( J, ILAST )  210          CONTINUE*               IF( ILZ ) THEN                  DO 220 J = 1, N                     Z( J, ILAST ) = -Z( J, ILAST )  220             CONTINUE               END IF            END IF**           Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.)**           Recompute shift*            CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA,     $                  B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1,     $                  TEMP, WR, TEMP2, WI )**           If standardization has perturbed the shift onto real line,*           do another (real single-shift) QR step.*            IF( WI.EQ.ZERO )     $         GO TO 350            S1INV = ONE / S1**           Do EISPACK (QZVAL) computation of alpha and beta*            A11 = A( ILAST-1, ILAST-1 )            A21 = A( ILAST, ILAST-1 )            A12 = A( ILAST-1, ILAST )            A22 = A( ILAST, ILAST )**           Compute complex Givens rotation on right*           (Assume some element of C = (sA - wB) > unfl )*                            __*           (sA - wB) ( CZ   -SZ )*                     ( SZ    CZ )*            C11R = S1*A11 - WR*B11            C11I = -WI*B11            C12 = S1*A12            C21 = S1*A21            C22R = S1*A22 - WR*B22            C22I = -WI*B22*            IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+     $          ABS( C22R )+ABS( C22I ) ) THEN               T = DLAPY3( C12, C11R, C11I )               CZ = C12 / T               SZR = -C11R / T               SZI = -C11I / T            ELSE               CZ = DLAPY2( C22R, C22I )               IF( CZ.LE.SAFMIN ) THEN                  CZ = ZERO                  SZR = ONE                  SZI = ZERO               ELSE                  TEMPR = C22R / CZ                  TEMPI = C22I / CZ                  T = DLAPY2( CZ, C21 )                  CZ = CZ / T                  SZR = -C21*TEMPR / T                  SZI = C21*TEMPI / T               END IF            END IF**           Compute Givens rotation on left**           (  CQ   SQ )*           (  __      )  A or B*           ( -SQ   CQ )*            AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )            BN = ABS( B11 ) + ABS( B22 )            WABS = ABS( WR ) + ABS( WI )            IF( S1*AN.GT.WABS*BN ) THEN               CQ = CZ*B11               SQR = SZR*B22               SQI = -SZI*B22            ELSE               A1R = CZ*A11 + SZR*A12               A1I = SZI*A12               A2R = CZ*A21 + SZR*A22               A2I = SZI*A22               CQ = DLAPY2( A1R, A1I )               IF( CQ.LE.SAFMIN ) THEN                  CQ = ZERO                  SQR = ONE                  SQI = ZERO               ELSE                  TEMPR = A1R / CQ                  TEMPI = A1I / CQ                  SQR = TEMPR*A2R + TEMPI*A2I                  SQI = TEMPI*A2R - TEMPR*A2I               END IF            END IF            T = DLAPY3( CQ, SQR, SQI )            CQ = CQ / T            SQR = SQR / T            SQI = SQI / T**           Compute diagonal elements of QBZ*            TEMPR = SQR*SZR - SQI*SZI            TEMPI = SQR*SZI + SQI*SZR            B1R = CQ*CZ*B11 + TEMPR*B22            B1I = TEMPI*B22            B1A = DLAPY2( B1R, B1I )            B2R = CQ*CZ*B22 + TEMPR*B11            B2I = -TEMPI*B11            B2A = DLAPY2( B2R, B2I )**           Normalize so beta > 0, and Im( alpha1 ) > 0*            BETA( ILAST-1 ) = B1A            BETA( ILAST ) = B2A            ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV            ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV            ALPHAR( ILAST ) = ( WR*B2A )*S1INV            ALPHAI( ILAST ) = -( WI*B2A )*S1INV**           Step 3: Go to next block -- exit if finished.*            ILAST = IFIRST - 1            IF( ILAST.LT.ILO )     $         GO TO 380**           Reset counters*            IITER = 0            ESHIFT = ZERO            IF( .NOT.ILSCHR ) THEN               ILASTM = ILAST               IF( IFRSTM.GT.ILAST )     $            IFRSTM = ILO            END IF            GO TO 350         ELSE**           Usual case: 3x3 or larger block, using Francis implicit*                       double-shift**                                    2*           Eigenvalue equation is  w  - c w + d = 0,**                                         -1 2        -1*           so compute 1st column of  (A B  )  - c A B   + d*           using the formula in QZIT (from EISPACK)**           We assume that the block is at least 3x3*            AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) /     $             ( BSCALE*B( ILAST-1, ILAST-1 ) )            AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) /     $             ( BSCALE*B( ILAST-1, ILAST-1 ) )            AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) /     $             ( BSCALE*B( ILAST, ILAST ) )            AD22 = ( ASCALE*A( ILAST, ILAST ) ) /     $             ( BSCALE*B( ILAST, ILAST ) )            U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST )            AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) /     $              ( BSCALE*B( IFIRST, IFIRST ) )            AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) /     $              ( BSCALE*B( IFIRST, IFIRST ) )            AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) /     $              ( BSCALE*B( IFIRST+1, IFIRST+1 ) )            AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) /     $              ( BSCALE*B( IFIRST+1, IFIRST+1 ) )            AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) /     $              ( BSCALE*B( IFIRST+1, IFIRST+1 ) )            U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 )*            V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +     $               AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L            V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-     $               ( AD22-AD11L )+AD21*U12 )*AD21L            V( 3 ) = AD32L*AD21L*            ISTART = IFIRST*            CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU )            V( 1 ) = ONE**           Sweep*            DO 290 J = ISTART, ILAST - 2**              All but last elements: use 3x3 Householder transforms.**              Zero (j-1)st column of A*               IF( J.GT.ISTART ) THEN                  V( 1 ) = A( J, J-1 )                  V( 2 ) = A( J+1, J-1 )                  V( 3 ) = A( J+2, J-1 )*                  CALL DLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU )                  V( 1 ) = ONE                  A( J+1, J-1 ) = ZERO                  A( J+2, J-1 ) = ZERO               END IF*               DO 230 JC = J, ILASTM                  TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )*     $                   A( J+2, JC ) )                  A( J, JC ) = A( J, JC ) - TEMP                  A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 )                  A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 )                  TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )*     $                    B( J+2, JC ) )                  B( J, JC ) = B( J, JC ) - TEMP2                  B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 )                  B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 )  230          CONTINUE               IF( ILQ ) THEN                  DO 240 JR = 1, N                     TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*     $                      Q( JR, J+2 ) )                     Q( JR, J ) = Q( JR, J ) - TEMP                     Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )                     Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )  240             CONTINUE               END IF**              Zero j-th column of B (see DLAGBC for details)**              Swap rows to pivot*               ILPIVT = .FALSE.               TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) )               TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) )               IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN                  SCALE = ZERO                  U1 = ONE                  U2 = ZERO                  GO TO 250               ELSE IF( TEMP.GE.TEMP2 ) THEN                  W11 = B( J+1, J+1 )                  W21 = B( J+2, J+1 )                  W12 = B( J+1, J+2 )                  W22 = B( J+2, J+2 )                  U1 = B( J+1, J )                  U2 = B( J+2, J )               ELSE                  W21 = B( J+1, J+1 )                  W11 = B( J+2, J+1 )                  W22 = B( J+1, J+2 )                  W12 = B( J+2, J+2 )                  U2 = B( J+1, J )                  U1 = B( J+2, J )               END IF**              Swap columns if nec.*               IF( ABS( W12 ).GT.ABS( W11 ) ) THEN                  ILPIVT = .TRUE.                  TEMP = W12                  TEMP2 = W22                  W12 = W11                  W22 = W21                  W11 = TEMP                  W21 = TEMP2               END IF**              LU-factor*               TEMP = W21 / W11               U2 = U2 - TEMP*U1               W22 = W22 - TEMP*W12               W21 = ZERO**              Compute SCALE*               SCALE = ONE               IF( ABS( W22 ).LT.SAFMIN ) THEN                  SCALE = ZERO                  U2 = ONE                  U1 = -W12 / W11                  GO TO 250               END IF               IF( ABS( W22 ).LT.ABS( U2 ) )     $            SCALE = ABS( W22 / U2 )               IF( ABS( W11 ).LT.ABS( U1 ) )     $            SCALE = MIN( SCALE, ABS( W11 / U1 ) )**              Solve*               U2 = ( SCALE*U2 ) / W22               U1 = ( SCALE*U1-W12*U2 ) / W11*  250          CONTINUE               IF( ILPIVT ) THEN                  TEMP = U2                  U2 = U1                  U1 = TEMP               END IF**              Compute Householder Vector*               T = SQRT( SCALE**2+U1**2+U2**2 )               TAU = ONE + SCALE / T               VS = -ONE / ( SCALE+T )               V( 1 ) = ONE               V( 2 ) = VS*U1               V( 3 ) = VS*U2**              Apply transformations from the right.*               DO 260 JR = IFRSTM, MIN( J+3, ILAST )                  TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )*     $                   A( JR, J+2 ) )                  A( JR, J ) = A( JR, J ) - TEMP                  A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 )                  A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 )  260          CONTINUE               DO 270 JR = IFRSTM, J + 2                  TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )*     $                   B( JR, J+2 ) )                  B( JR, J ) = B( JR, J ) - TEMP                  B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 )                  B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 )  270          CONTINUE               IF( ILZ ) THEN                  DO 280 JR = 1, N                     TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*     $                      Z( JR, J+2 ) )                     Z( JR, J ) = Z( JR, J ) - TEMP                     Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )                     Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )  280             CONTINUE               END IF               B( J+1, J ) = ZERO               B( J+2, J ) = ZERO  290       CONTINUE**           Last elements: Use Givens rotations**           Rotations from the left*            J = ILAST - 1            TEMP = A( J, J-1 )            CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )            A( J+1, J-1 ) = ZERO*            DO 300 JC = J, ILASTM               TEMP = C*A( J, JC ) + S*A( J+1, JC )               A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC )               A( J, JC ) = TEMP               TEMP2 = C*B( J, JC ) + S*B( J+1, JC )               B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC )               B( J, JC ) = TEMP2  300       CONTINUE            IF( ILQ ) THEN               DO 310 JR = 1, N                  TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )                  Q( JR, J ) = TEMP  310          CONTINUE            END IF**           Rotations from the right.*            TEMP = B( J+1, J+1 )            CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )            B( J+1, J ) = ZERO*            DO 320 JR = IFRSTM, ILAST               TEMP = C*A( JR, J+1 ) + S*A( JR, J )               A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J )               A( JR, J+1 ) = TEMP  320       CONTINUE            DO 330 JR = IFRSTM, ILAST - 1               TEMP = C*B( JR, J+1 ) + S*B( JR, J )               B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J )               B( JR, J+1 ) = TEMP  330       CONTINUE            IF( ILZ ) THEN               DO 340 JR = 1, N                  TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )                  Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )                  Z( JR, J+1 ) = TEMP  340          CONTINUE            END IF**           End of Double-Shift code*         END IF*         GO TO 350**        End of iteration loop*  350    CONTINUE  360 CONTINUE**     Drop-through = non-convergence*  370 CONTINUE      INFO = ILAST      GO TO 420**     Successful completion of all QZ steps*  380 CONTINUE**     Set Eigenvalues 1:ILO-1*      DO 410 J = 1, ILO - 1         IF( B( J, J ).LT.ZERO ) THEN            IF( ILSCHR ) THEN               DO 390 JR = 1, J                  A( JR, J ) = -A( JR, J )                  B( JR, J ) = -B( JR, J )  390          CONTINUE            ELSE               A( J, J ) = -A( J, J )               B( J, J ) = -B( J, J )            END IF            IF( ILZ ) THEN               DO 400 JR = 1, N                  Z( JR, J ) = -Z( JR, J )  400          CONTINUE            END IF         END IF         ALPHAR( J ) = A( J, J )         ALPHAI( J ) = ZERO         BETA( J ) = B( J, J )  410 CONTINUE**     Normal Termination*      INFO = 0**     Exit (other than argument error) -- return optimal workspace size*  420 CONTINUE      WORK( 1 ) = DBLE( N )      RETURN**     End of DHGEQZ*      END      SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,     $                   VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,     $                   IFAILR, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      CHARACTER          EIGSRC, INITV, SIDE      INTEGER            INFO, LDH, LDVL, LDVR, M, MM, N*     ..*     .. Array Arguments ..      LOGICAL            SELECT( * )      INTEGER            IFAILL( * ), IFAILR( * )      DOUBLE PRECISION   H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),     $                   WI( * ), WORK( * ), WR( * )*     ..**  Purpose*  =======**  DHSEIN uses inverse iteration to find specified right and/or left*  eigenvectors of a real upper Hessenberg matrix H.**  The right eigenvector x and the left eigenvector y of the matrix H*  corresponding to an eigenvalue w are defined by:**               H * x = w * x,     y**h * H = w * y**h**  where y**h denotes the conjugate transpose of the vector y.**  Arguments*  =========**  SIDE    (input) CHARACTER*1*          = 'R
': compute right eigenvectors only;*          = 'L
': compute left eigenvectors only;*          = 'B



': compute both right and left eigenvectors.**  EIGSRC  (input) CHARACTER*1*          Specifies the source of eigenvalues supplied in (WR,WI):*          = 'Q





': the eigenvalues were found using DHSEQR; thus, if*                 H has zero subdiagonal elements, and so is*                 block-triangular, then the j-th eigenvalue can be*                 assumed to be an eigenvalue of the block containing*                 the j-th row/column.  This property allows DHSEIN to*                 perform inverse iteration on just one diagonal block.*          = 'N





': no assumptions are made on the correspondence*                 between eigenvalues and diagonal blocks.  In this*                 case, DHSEIN must always perform inverse iteration*                 using the whole matrix H.**  INITV   (input) CHARACTER*1*          = 'N
': no initial vectors are supplied;*          = 'U































': user-supplied initial vectors are stored in the arrays*                 VL and/or VR.**  SELECT  (input/output) LOGICAL array, dimension (N)*          Specifies the eigenvectors to be computed. To select the*          real eigenvector corresponding to a real eigenvalue WR(j),*          SELECT(j) must be set to .TRUE.. To select the complex*          eigenvector corresponding to a complex eigenvalue*          (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),*          either SELECT(j) or SELECT(j+1) or both must be set to*          .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is*          .FALSE..**  N       (input) INTEGER*          The order of the matrix H.  N >= 0.**  H       (input) DOUBLE PRECISION array, dimension (LDH,N)*          The upper Hessenberg matrix H.**  LDH     (input) INTEGER*          The leading dimension of the array H.  LDH >= max(1,N).**  WR      (input/output) DOUBLE PRECISION array, dimension (N)*  WI      (input) DOUBLE PRECISION array, dimension (N)*          On entry, the real and imaginary parts of the eigenvalues of*          H; a complex conjugate pair of eigenvalues must be stored in*          consecutive elements of WR and WI.*          On exit, WR may have been altered since close eigenvalues*          are perturbed slightly in searching for independent*          eigenvectors.**  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)*          On entry, if INITV = 'U' and SIDE = 'L' or 'B




', VL must*          contain starting vectors for the inverse iteration for the*          left eigenvectors; the starting vector for each eigenvector*          must be in the same column(s) in which the eigenvector will*          be stored.*          On exit, if SIDE = 'L' or 'B





', the left eigenvectors*          specified by SELECT will be stored consecutively in the*          columns of VL, in the same order as their eigenvalues. A*          complex eigenvector corresponding to a complex eigenvalue is*          stored in two consecutive columns, the first holding the real*          part and the second the imaginary part.*          If SIDE = 'R



', VL is not referenced.**  LDVL    (input) INTEGER*          The leading dimension of the array VL.*          LDVL >= max(1,N) if SIDE = 'L' or 'B


'; LDVL >= 1 otherwise.**  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)*          On entry, if INITV = 'U' and SIDE = 'R' or 'B




', VR must*          contain starting vectors for the inverse iteration for the*          right eigenvectors; the starting vector for each eigenvector*          must be in the same column(s) in which the eigenvector will*          be stored.*          On exit, if SIDE = 'R' or 'B





', the right eigenvectors*          specified by SELECT will be stored consecutively in the*          columns of VR, in the same order as their eigenvalues. A*          complex eigenvector corresponding to a complex eigenvalue is*          stored in two consecutive columns, the first holding the real*          part and the second the imaginary part.*          If SIDE = 'L



', VR is not referenced.**  LDVR    (input) INTEGER*          The leading dimension of the array VR.*          LDVR >= max(1,N) if SIDE = 'R' or 'B













'; LDVR >= 1 otherwise.**  MM      (input) INTEGER*          The number of columns in the arrays VL and/or VR. MM >= M.**  M       (output) INTEGER*          The number of columns in the arrays VL and/or VR required to*          store the eigenvectors; each selected real eigenvector*          occupies one column and each selected complex eigenvector*          occupies two columns.**  WORK    (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)**  IFAILL  (output) INTEGER array, dimension (MM)*          If SIDE = 'L' or 'B





', IFAILL(i) = j > 0 if the left*          eigenvector in the i-th column of VL (corresponding to the*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the*          eigenvector converged satisfactorily. If the i-th and (i+1)th*          columns of VL hold a complex eigenvector, then IFAILL(i) and*          IFAILL(i+1) are set to the same value.*          If SIDE = 'R


', IFAILL is not referenced.**  IFAILR  (output) INTEGER array, dimension (MM)*          If SIDE = 'R' or 'B





', IFAILR(i) = j > 0 if the right*          eigenvector in the i-th column of VR (corresponding to the*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the*          eigenvector converged satisfactorily. If the i-th and (i+1)th*          columns of VR hold a complex eigenvector, then IFAILR(i) and*          IFAILR(i+1) are set to the same value.*          If SIDE = 'L










































', IFAILR is not referenced.**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value*          > 0:  if INFO = i, i is the number of eigenvectors which*                failed to converge; see IFAILL and IFAILR for further*                details.**  Further Details*  ===============**  Each eigenvector is normalized so that the element of largest*  magnitude has magnitude 1; here the magnitude of a complex number*  (x,y) is taken to be |x|+|y|.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, ONE      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      LOGICAL            BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV      INTEGER            I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK      DOUBLE PRECISION   BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,     $                   WKR*     ..*     .. External Functions ..      LOGICAL            LSAME      DOUBLE PRECISION   DLAMCH, DLANHS      EXTERNAL           LSAME, DLAMCH, DLANHS*     ..*     .. External Subroutines ..      EXTERNAL           DLAEIN, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX*     ..*     .. Executable Statements ..**     Decode and test the input parameters.*      BOTHV = LSAME( SIDE, 'B
' )      RIGHTV = LSAME( SIDE, 'R
' ) .OR. BOTHV      LEFTV = LSAME( SIDE, 'L

' ) .OR. BOTHV*      FROMQR = LSAME( EIGSRC, 'Q

' )*      NOINIT = LSAME( INITV, 'N



























' )**     Set M to the number of columns required to store the selected*     eigenvectors, and standardize the array SELECT.*      M = 0      PAIR = .FALSE.      DO 10 K = 1, N         IF( PAIR ) THEN            PAIR = .FALSE.            SELECT( K ) = .FALSE.         ELSE            IF( WI( K ).EQ.ZERO ) THEN               IF( SELECT( K ) )     $            M = M + 1            ELSE               PAIR = .TRUE.               IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN                  SELECT( K ) = .TRUE.                  M = M + 2               END IF            END IF         END IF   10 CONTINUE*      INFO = 0      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN         INFO = -1      ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N

' ) ) THEN         INFO = -2      ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U













' ) ) THEN         INFO = -3      ELSE IF( N.LT.0 ) THEN         INFO = -5      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN         INFO = -7      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN         INFO = -11      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN         INFO = -13      ELSE IF( MM.LT.M ) THEN         INFO = -14      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DHSEIN










', -INFO )         RETURN      END IF**     Quick return if possible.*      IF( N.EQ.0 )     $   RETURN**     Set machine-dependent constants.*      UNFL = DLAMCH( 'Safe minimum
' )      ULP = DLAMCH( 'Precision






















































' )      SMLNUM = UNFL*( N / ULP )      BIGNUM = ( ONE-ULP ) / SMLNUM*      LDWORK = N + 1*      KL = 1      KLN = 0      IF( FROMQR ) THEN         KR = 0      ELSE         KR = N      END IF      KSR = 1*      DO 120 K = 1, N         IF( SELECT( K ) ) THEN**           Compute eigenvector(s) corresponding to W(K).*            IF( FROMQR ) THEN**              If affiliation of eigenvalues is known, check whether*              the matrix splits.**              Determine KL and KR such that 1 <= KL <= K <= KR <= N*              and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or*              KR = N).**              Then inverse iteration can be performed with the*              submatrix H(KL:N,KL:N) for a left eigenvector, and with*              the submatrix H(1:KR,1:KR) for a right eigenvector.*               DO 20 I = K, KL + 1, -1                  IF( H( I, I-1 ).EQ.ZERO )     $               GO TO 30   20          CONTINUE   30          CONTINUE               KL = I               IF( K.GT.KR ) THEN                  DO 40 I = K, N - 1                     IF( H( I+1, I ).EQ.ZERO )     $                  GO TO 50   40             CONTINUE   50             CONTINUE                  KR = I               END IF            END IF*            IF( KL.NE.KLN ) THEN               KLN = KL**              Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it*              has not ben computed before.*               HNORM = DLANHS( 'I







































































































































', KR-KL+1, H( KL, KL ), LDH, WORK )               IF( HNORM.GT.ZERO ) THEN                  EPS3 = HNORM*ULP               ELSE                  EPS3 = SMLNUM               END IF            END IF**           Perturb eigenvalue if it is close to any previous*           selected eigenvalues affiliated to the submatrix*           H(KL:KR,KL:KR). Close roots are modified by EPS3.*            WKR = WR( K )            WKI = WI( K )   60       CONTINUE            DO 70 I = K - 1, KL, -1               IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+     $             ABS( WI( I )-WKI ).LT.EPS3 ) THEN                  WKR = WKR + EPS3                  GO TO 60               END IF   70       CONTINUE            WR( K ) = WKR*            PAIR = WKI.NE.ZERO            IF( PAIR ) THEN               KSI = KSR + 1            ELSE               KSI = KSR            END IF            IF( LEFTV ) THEN**              Compute left eigenvector.*               CALL DLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,     $                      WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),     $                      WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,     $                      BIGNUM, IINFO )               IF( IINFO.GT.0 ) THEN                  IF( PAIR ) THEN                     INFO = INFO + 2                  ELSE                     INFO = INFO + 1                  END IF                  IFAILL( KSR ) = K                  IFAILL( KSI ) = K               ELSE                  IFAILL( KSR ) = 0                  IFAILL( KSI ) = 0               END IF               DO 80 I = 1, KL - 1                  VL( I, KSR ) = ZERO   80          CONTINUE               IF( PAIR ) THEN                  DO 90 I = 1, KL - 1                     VL( I, KSI ) = ZERO   90             CONTINUE               END IF            END IF            IF( RIGHTV ) THEN**              Compute right eigenvector.*               CALL DLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,     $                      VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,     $                      WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,     $                      IINFO )               IF( IINFO.GT.0 ) THEN                  IF( PAIR ) THEN                     INFO = INFO + 2                  ELSE                     INFO = INFO + 1                  END IF                  IFAILR( KSR ) = K                  IFAILR( KSI ) = K               ELSE                  IFAILR( KSR ) = 0                  IFAILR( KSI ) = 0               END IF               DO 100 I = KR + 1, N                  VR( I, KSR ) = ZERO  100          CONTINUE               IF( PAIR ) THEN                  DO 110 I = KR + 1, N                     VR( I, KSI ) = ZERO  110             CONTINUE               END IF            END IF*            IF( PAIR ) THEN               KSR = KSR + 2            ELSE               KSR = KSR + 1            END IF         END IF  120 CONTINUE*      RETURN**     End of DHSEIN*      END      SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,     $                   LDZ, WORK, LWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      CHARACTER          COMPZ, JOB      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   H( LDH, * ), WI( * ), WORK( * ), WR( * ),     $                   Z( LDZ, * )*     ..**  Purpose*  =======**  DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H*  and, optionally, the matrices T and Z from the Schur decomposition*  H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur*  form), and Z is the orthogonal matrix of Schur vectors.**  Optionally Z may be postmultiplied into an input orthogonal matrix Q,*  so that this routine can give the Schur factorization of a matrix A*  which has been reduced to the Hessenberg form H by the orthogonal*  matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.**  Arguments*  =========**  JOB     (input) CHARACTER*1*          = 'E
':  compute eigenvalues only;*          = 'S


':  compute eigenvalues and the Schur form T.**  COMPZ   (input) CHARACTER*1*          = 'N
':  no Schur vectors are computed;*          = 'I

':  Z is initialized to the unit matrix and the matrix Z*                  of Schur vectors of H is returned;*          = 'V

















':  Z must contain an orthogonal matrix Q on entry, and*                  the product Q*Z is returned.**  N       (input) INTEGER*          The order of the matrix H.  N >= 0.**  ILO     (input) INTEGER*  IHI     (input) INTEGER*          It is assumed that H is already upper triangular in rows*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally*          set by a previous call to DGEBAL, and then passed to SGEHRD*          when the matrix output by DGEBAL is reduced to Hessenberg*          form. Otherwise ILO and IHI should be set to 1 and N*          respectively.*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.**  H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)*          On entry, the upper Hessenberg matrix H.*          On exit, if JOB = 'S



', H contains the upper quasi-triangular*          matrix T from the Schur decomposition (the Schur form);*          2-by-2 diagonal blocks (corresponding to complex conjugate*          pairs of eigenvalues) are returned in standard form, with*          H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E











',*          the contents of H are unspecified on exit.**  LDH     (input) INTEGER*          The leading dimension of the array H. LDH >= max(1,N).**  WR      (output) DOUBLE PRECISION array, dimension (N)*  WI      (output) DOUBLE PRECISION array, dimension (N)*          The real and imaginary parts, respectively, of the computed*          eigenvalues. If two eigenvalues are computed as a complex*          conjugate pair, they are stored in consecutive elements of*          WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and*          WI(i+1) < 0. If JOB = 'S






', the eigenvalues are stored in the*          same order as on the diagonal of the Schur form returned in*          H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2*          diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and*          WI(i+1) = -WI(i).**  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)*          If COMPZ = 'N
': Z is not referenced.*          If COMPZ = 'I

': on entry, Z need not be set, and on exit, Z*          contains the orthogonal matrix Z of the Schur vectors of H.*          If COMPZ = 'V







': on entry Z must contain an N-by-N matrix Q,*          which is assumed to be equal to the unit matrix except for*          the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.*          Normally Q is the orthogonal matrix generated by DORGHR after*          the call to DGEHRD which formed the Hessenberg matrix H.**  LDZ     (input) INTEGER*          The leading dimension of the array Z.*          LDZ >= max(1,N) if COMPZ = 'I' or 'V
























































'; LDZ >= 1 otherwise.**  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.**  LWORK   (input) INTEGER*          The dimension of the array WORK.  LWORK >= max(1,N).**          If LWORK = -1, then a workspace query is assumed; the routine*          only calculates the optimal size of the WORK array, returns*          this value as the first entry of the WORK array, and no error*          message related to LWORK is issued by XERBLA.**  INFO    (output) INTEGER*          = 0:  successful exit*          < 0:  if INFO = -i, the i-th argument had an illegal value*          > 0:  if INFO = i, DHSEQR failed to compute all of the*                eigenvalues in a total of 30*(IHI-ILO+1) iterations;*                elements 1:ilo-1 and i+1:n of WR and WI contain those*                eigenvalues which have been successfully computed.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, ONE, TWO      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )      DOUBLE PRECISION   CONST      PARAMETER          ( CONST = 1.5D+0 )      INTEGER            NSMAX, LDS      PARAMETER          ( NSMAX = 15, LDS = NSMAX )*     ..*     .. Local Scalars ..      LOGICAL            INITZ, LQUERY, WANTT, WANTZ      INTEGER            I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L,     $                   MAXB, NH, NR, NS, NV      DOUBLE PRECISION   ABSW, OVFL, SMLNUM, TAU, TEMP, TST1, ULP, UNFL*     ..*     .. Local Arrays ..      DOUBLE PRECISION   S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 )*     ..*     .. External Functions ..      LOGICAL            LSAME      INTEGER            IDAMAX, ILAENV      DOUBLE PRECISION   DLAMCH, DLANHS, DLAPY2      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DGEMV, DLACPY, DLAHQR, DLARFG, DLARFX,     $                   DLASET, DSCAL, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN*     ..*     .. Executable Statements ..**     Decode and test the input parameters*      WANTT = LSAME( JOB, 'S
' )      INITZ = LSAME( COMPZ, 'I
' )      WANTZ = INITZ .OR. LSAME( COMPZ, 'V




' )*      INFO = 0      WORK( 1 ) = MAX( 1, N )      LQUERY = ( LWORK.EQ.-1 )      IF( .NOT.LSAME( JOB, 'E

' ) .AND. .NOT.WANTT ) THEN         INFO = -1      ELSE IF( .NOT.LSAME( COMPZ, 'N















' ) .AND. .NOT.WANTZ ) THEN         INFO = -2      ELSE IF( N.LT.0 ) THEN         INFO = -3      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN         INFO = -4      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN         INFO = -5      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN         INFO = -7      ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN         INFO = -11      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN         INFO = -13      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DHSEQR








', -INFO )         RETURN      ELSE IF( LQUERY ) THEN         RETURN      END IF**     Initialize Z, if necessary*      IF( INITZ )     $   CALL DLASET( 'Full


































', N, N, ZERO, ONE, Z, LDZ )**     Store the eigenvalues isolated by DGEBAL.*      DO 10 I = 1, ILO - 1         WR( I ) = H( I, I )         WI( I ) = ZERO   10 CONTINUE      DO 20 I = IHI + 1, N         WR( I ) = H( I, I )         WI( I ) = ZERO   20 CONTINUE**     Quick return if possible.*      IF( N.EQ.0 )     $   RETURN      IF( ILO.EQ.IHI ) THEN         WR( ILO ) = H( ILO, ILO )         WI( ILO ) = ZERO         RETURN      END IF**     Set rows and columns ILO to IHI to zero below the first*     subdiagonal.*      DO 40 J = ILO, IHI - 2         DO 30 I = J + 2, N            H( I, J ) = ZERO   30    CONTINUE   40 CONTINUE      NH = IHI - ILO + 1**     Determine the order of the multi-shift QR algorithm to be used.*      NS = ILAENV( 4, 'DHSEQR
', JOB // COMPZ, N, ILO, IHI, -1 )      MAXB = ILAENV( 8, 'DHSEQR
















', JOB // COMPZ, N, ILO, IHI, -1 )      IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN**        Use the standard double-shift algorithm*         CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,     $                IHI, Z, LDZ, INFO )         RETURN      END IF      MAXB = MAX( 3, MAXB )      NS = MIN( NS, MAXB, NSMAX )**     Now 2 < NS <= MAXB < NH.**     Set machine-dependent constants for the stopping criterion.*     If norm(H) <= sqrt(OVFL), overflow should not occur.*      UNFL = DLAMCH( 'Safe minimum


' )      OVFL = ONE / UNFL      CALL DLABAD( UNFL, OVFL )      ULP = DLAMCH( 'Precision






































' )      SMLNUM = UNFL*( NH / ULP )**     I1 and I2 are the indices of the first row and last column of H*     to which transformations must be applied. If eigenvalues only are*     being computed, I1 and I2 are set inside the main loop.*      IF( WANTT ) THEN         I1 = 1         I2 = N      END IF**     ITN is the total number of multiple-shift QR iterations allowed.*      ITN = 30*NH**     The main loop begins here. I is the loop index and decreases from*     IHI to ILO in steps of at most MAXB. Each iteration of the loop*     works with the active submatrix in rows and columns L to I.*     Eigenvalues I+1 to IHI have already converged. Either L = ILO or*     H(L,L-1) is negligible so that the matrix splits.*      I = IHI   50 CONTINUE      L = ILO      IF( I.LT.ILO )     $   GO TO 170**     Perform multiple-shift QR iterations on rows and columns ILO to I*     until a submatrix of order at most MAXB splits off at the bottom*     because a subdiagonal element has become negligible.*      DO 150 ITS = 0, ITN**        Look for a single small subdiagonal element.*         DO 60 K = I, L + 1, -1            TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )            IF( TST1.EQ.ZERO )     $         TST1 = DLANHS( '1







































', I-L+1, H( L, L ), LDH, WORK )            IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )     $         GO TO 70   60    CONTINUE   70    CONTINUE         L = K         IF( L.GT.ILO ) THEN**           H(L,L-1) is negligible.*            H( L, L-1 ) = ZERO         END IF**        Exit from loop if a submatrix of order <= MAXB has split off.*         IF( L.GE.I-MAXB+1 )     $      GO TO 160**        Now the active submatrix is in rows and columns L to I. If*        eigenvalues only are being computed, only the active submatrix*        need be transformed.*         IF( .NOT.WANTT ) THEN            I1 = L            I2 = I         END IF*         IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN**           Exceptional shifts.*            DO 80 II = I - NS + 1, I               WR( II ) = CONST*( ABS( H( II, II-1 ) )+     $                    ABS( H( II, II ) ) )               WI( II ) = ZERO   80       CONTINUE         ELSE**           Use eigenvalues of trailing submatrix of order NS as shifts.*            CALL DLACPY( 'Full

































', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S,     $                   LDS )            CALL DLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS,     $                   WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ,     $                   IERR )            IF( IERR.GT.0 ) THEN**              If DLAHQR failed to compute all NS eigenvalues, use the*              unconverged diagonal elements as the remaining shifts.*               DO 90 II = 1, IERR                  WR( I-NS+II ) = S( II, II )                  WI( I-NS+II ) = ZERO   90          CONTINUE            END IF         END IF**        Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))*        where G is the Hessenberg submatrix H(L:I,L:I) and w is*        the vector of shifts (stored in WR and WI). The result is*        stored in the local array V.*         V( 1 ) = ONE         DO 100 II = 2, NS + 1            V( II ) = ZERO  100    CONTINUE         NV = 1         DO 120 J = I - NS + 1, I            IF( WI( J ).GE.ZERO ) THEN               IF( WI( J ).EQ.ZERO ) THEN**                 real shift*                  CALL DCOPY( NV+1, V, 1, VV, 1 )                  CALL DGEMV( 'No transpose







', NV+1, NV, ONE, H( L, L ),     $                        LDH, VV, 1, -WR( J ), V, 1 )                  NV = NV + 1               ELSE IF( WI( J ).GT.ZERO ) THEN**                 complex conjugate pair of shifts*                  CALL DCOPY( NV+1, V, 1, VV, 1 )                  CALL DGEMV( 'No transpose






', NV+1, NV, ONE, H( L, L ),     $                        LDH, V, 1, -TWO*WR( J ), VV, 1 )                  ITEMP = IDAMAX( NV+1, VV, 1 )                  TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM )                  CALL DSCAL( NV+1, TEMP, VV, 1 )                  ABSW = DLAPY2( WR( J ), WI( J ) )                  TEMP = ( TEMP*ABSW )*ABSW                  CALL DGEMV( 'No transpose

















































', NV+2, NV+1, ONE,     $                        H( L, L ), LDH, VV, 1, TEMP, V, 1 )                  NV = NV + 2               END IF**              Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,*              reset it to the unit vector.*               ITEMP = IDAMAX( NV, V, 1 )               TEMP = ABS( V( ITEMP ) )               IF( TEMP.EQ.ZERO ) THEN                  V( 1 ) = ONE                  DO 110 II = 2, NV                     V( II ) = ZERO  110             CONTINUE               ELSE                  TEMP = MAX( TEMP, SMLNUM )                  CALL DSCAL( NV, ONE / TEMP, V, 1 )               END IF            END IF  120    CONTINUE**        Multiple-shift QR step*         DO 140 K = L, I - 1**           The first iteration of this loop determines a reflection G*           from the vector V and applies it from left and right to H,*           thus creating a nonzero bulge below the subdiagonal.**           Each subsequent iteration determines a reflection G to*           restore the Hessenberg form in the (K-1)th column, and thus*           chases the bulge one step toward the bottom of the active*           submatrix. NR is the order of G.*            NR = MIN( NS+1, I-K+1 )            IF( K.GT.L )     $         CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )            CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU )            IF( K.GT.L ) THEN               H( K, K-1 ) = V( 1 )               DO 130 II = K + 1, I                  H( II, K-1 ) = ZERO  130          CONTINUE            END IF            V( 1 ) = ONE**           Apply G from the left to transform the rows of the matrix in*           columns K to I2.*            CALL DLARFX( 'Left





', NR, I2-K+1, V, TAU, H( K, K ), LDH,     $                   WORK )**           Apply G from the right to transform the columns of the*           matrix in rows I1 to min(K+NR,I).*            CALL DLARFX( 'Right






', MIN( K+NR, I )-I1+1, NR, V, TAU,     $                   H( I1, K ), LDH, WORK )*            IF( WANTZ ) THEN**              Accumulate transformations in the matrix Z*               CALL DLARFX( 'Right





















































































































































































', NH, NR, V, TAU, Z( ILO, K ), LDZ,     $                      WORK )            END IF  140    CONTINUE*  150 CONTINUE**     Failure to converge in remaining number of iterations*      INFO = I      RETURN*  160 CONTINUE**     A submatrix of order <= MAXB in rows and columns L to I has split*     off. Use the double-shift QR algorithm to handle it.*      CALL DLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z,     $             LDZ, INFO )      IF( INFO.GT.0 )     $   RETURN**     Decrement number of remaining iterations, and return to start of*     the main loop with a new value of I.*      ITN = ITN - ITS      I = L - 1      GO TO 50*  170 CONTINUE      WORK( 1 ) = MAX( 1, N )      RETURN**     End of DHSEQR*      END      SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,     $                   WORK, IWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            ICOMPQ, INFO, LDQ, LDQS, N, QSIZ*     ..*     .. Array Arguments ..      INTEGER            IWORK( * )      DOUBLE PRECISION   D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),     $                   WORK( * )*     ..**  Purpose*  =======**  DLAED0 computes all eigenvalues and corresponding eigenvectors of a*  symmetric tridiagonal matrix using the divide and conquer method.**  Arguments*  =========**  ICOMPQ  (input) INTEGER*          = 0:  Compute eigenvalues only.*          = 1:  Compute eigenvectors of original dense symmetric matrix*                also.  On entry, Q contains the orthogonal matrix used*                to reduce the original matrix to tridiagonal form.*          = 2:  Compute eigenvalues and eigenvectors of tridiagonal*                matrix.**  QSIZ   (input) INTEGER*         The dimension of the orthogonal matrix used to reduce*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.**  N      (input) INTEGER*         The dimension of the symmetric tridiagonal matrix.  N >= 0.**  D      (input/output) DOUBLE PRECISION array, dimension (N)*         On entry, the main diagonal of the tridiagonal matrix.*         On exit, its eigenvalues.**  E      (input) DOUBLE PRECISION array, dimension (N-1)*         The off-diagonal elements of the tridiagonal matrix.*         On exit, E has been destroyed.**  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)*         On entry, Q must contain an N-by-N orthogonal matrix.*         If ICOMPQ = 0    Q is not referenced.*         If ICOMPQ = 1    On entry, Q is a subset of the columns of the*                          orthogonal matrix used to reduce the full*                          matrix to tridiagonal form corresponding to*                          the subset of the full matrix which is being*                          decomposed at this time.*         If ICOMPQ = 2    On entry, Q will be the identity matrix.*                          On exit, Q contains the eigenvectors of the*                          tridiagonal matrix.**  LDQ    (input) INTEGER*         The leading dimension of the array Q.  If eigenvectors are*         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.**  QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)*         Referenced only when ICOMPQ = 1.  Used to store parts of*         the eigenvector matrix when the updating matrix multiplies*         take place.**  LDQS   (input) INTEGER*         The leading dimension of the array QSTORE.  If ICOMPQ = 1,*         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.**  WORK   (workspace) DOUBLE PRECISION array,*         If ICOMPQ = 0 or 1, the dimension of WORK must be at least*                     1 + 3*N + 2*N*lg N + 2*N**2*                     ( lg( N ) = smallest integer k*                                 such that 2^k >= N )*         If ICOMPQ = 2, the dimension of WORK must be at least*                     4*N + N**2.**  IWORK  (workspace) INTEGER array,*         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least*                        6 + 6*N + 5*N*lg N.*                        ( lg( N ) = smallest integer k*                                    such that 2^k >= N )*         If ICOMPQ = 2, the dimension of IWORK must be at least*                        3 + 5*N.**  INFO   (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.*          > 0:  The algorithm failed to compute an eigenvalue while*                working on the submatrix lying in rows and columns*                INFO/(N+1) through mod(INFO,N+1).**  Further Details*  ===============**  Based on contributions by*     Jeff Rutter, Computer Science Division, University of California*     at Berkeley, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, ONE, TWO      PARAMETER          ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )*     ..*     .. Local Scalars ..      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,     $                   IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,     $                   J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,     $                   SPM2, SUBMAT, SUBPBS, TLVLS      DOUBLE PRECISION   TEMP*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR,     $                   XERBLA*     ..*     .. External Functions ..      INTEGER            ILAENV      EXTERNAL           ILAENV*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, DBLE, INT, LOG, MAX*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN         INFO = -1      ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN         INFO = -2      ELSE IF( N.LT.0 ) THEN         INFO = -3      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN         INFO = -7      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN         INFO = -9      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLAED0








', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 )     $   RETURN*      SMLSIZ = ILAENV( 9, 'DLAED0', ' 












































































', 0, 0, 0, 0 )**     Determine the size and placement of the submatrices, and save in*     the leading elements of IWORK.*      IWORK( 1 ) = N      SUBPBS = 1      TLVLS = 0   10 CONTINUE      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN         DO 20 J = SUBPBS, 1, -1            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2            IWORK( 2*J-1 ) = IWORK( J ) / 2   20    CONTINUE         TLVLS = TLVLS + 1         SUBPBS = 2*SUBPBS         GO TO 10      END IF      DO 30 J = 2, SUBPBS         IWORK( J ) = IWORK( J ) + IWORK( J-1 )   30 CONTINUE**     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1*     using rank-1 modifications (cuts).*      SPM1 = SUBPBS - 1      DO 40 I = 1, SPM1         SUBMAT = IWORK( I ) + 1         SMM1 = SUBMAT - 1         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )   40 CONTINUE*      INDXQ = 4*N + 3      IF( ICOMPQ.NE.2 ) THEN**        Set up workspaces for eigenvalues only/accumulate new vectors*        routine*         TEMP = LOG( DBLE( N ) ) / LOG( TWO )         LGN = INT( TEMP )         IF( 2**LGN.LT.N )     $      LGN = LGN + 1         IF( 2**LGN.LT.N )     $      LGN = LGN + 1         IPRMPT = INDXQ + N + 1         IPERM = IPRMPT + N*LGN         IQPTR = IPERM + N*LGN         IGIVPT = IQPTR + N + 2         IGIVCL = IGIVPT + N*LGN*         IGIVNM = 1         IQ = IGIVNM + 2*N*LGN         IWREM = IQ + N**2 + 1**        Initialize pointers*         DO 50 I = 0, SUBPBS            IWORK( IPRMPT+I ) = 1            IWORK( IGIVPT+I ) = 1   50    CONTINUE         IWORK( IQPTR ) = 1      END IF**     Solve each submatrix eigenproblem at the bottom of the divide and*     conquer tree.*      CURR = 0      DO 70 I = 0, SPM1         IF( I.EQ.0 ) THEN            SUBMAT = 1            MATSIZ = IWORK( 1 )         ELSE            SUBMAT = IWORK( I ) + 1            MATSIZ = IWORK( I+1 ) - IWORK( I )         END IF         IF( ICOMPQ.EQ.2 ) THEN            CALL DSTEQR( 'I




', MATSIZ, D( SUBMAT ), E( SUBMAT ),     $                   Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )            IF( INFO.NE.0 )     $         GO TO 130         ELSE            CALL DSTEQR( 'I





', MATSIZ, D( SUBMAT ), E( SUBMAT ),     $                   WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,     $                   INFO )            IF( INFO.NE.0 )     $         GO TO 130            IF( ICOMPQ.EQ.1 ) THEN               CALL DGEMM( 'N', 'N























































































', QSIZ, MATSIZ, MATSIZ, ONE,     $                     Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+     $                     CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),     $                     LDQS )            END IF            IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2            CURR = CURR + 1         END IF         K = 1         DO 60 J = SUBMAT, IWORK( I+1 )            IWORK( INDXQ+J ) = K            K = K + 1   60    CONTINUE   70 CONTINUE**     Successively merge eigensystems of adjacent submatrices*     into eigensystem for the corresponding larger matrix.**     while ( SUBPBS > 1 )*      CURLVL = 1   80 CONTINUE      IF( SUBPBS.GT.1 ) THEN         SPM2 = SUBPBS - 2         DO 90 I = 0, SPM2, 2            IF( I.EQ.0 ) THEN               SUBMAT = 1               MATSIZ = IWORK( 2 )               MSD2 = IWORK( 1 )               CURPRB = 0            ELSE               SUBMAT = IWORK( I ) + 1               MATSIZ = IWORK( I+2 ) - IWORK( I )               MSD2 = MATSIZ / 2               CURPRB = CURPRB + 1            END IF**     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)*     into an eigensystem of size MATSIZ.*     DLAED1 is used only for the full eigensystem of a tridiagonal*     matrix.*     DLAED7 handles the cases in which eigenvalues only or eigenvalues*     and eigenvectors of a full symmetric matrix (which was reduced to*     tridiagonal form) are desired.*            IF( ICOMPQ.EQ.2 ) THEN               CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),     $                      LDQ, IWORK( INDXQ+SUBMAT ),     $                      E( SUBMAT+MSD2-1 ), MSD2, WORK,     $                      IWORK( SUBPBS+1 ), INFO )            ELSE               CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,     $                      D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,     $                      IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),     $                      MSD2, WORK( IQ ), IWORK( IQPTR ),     $                      IWORK( IPRMPT ), IWORK( IPERM ),     $                      IWORK( IGIVPT ), IWORK( IGIVCL ),     $                      WORK( IGIVNM ), WORK( IWREM ),     $                      IWORK( SUBPBS+1 ), INFO )            END IF            IF( INFO.NE.0 )     $         GO TO 130            IWORK( I / 2+1 ) = IWORK( I+2 )   90    CONTINUE         SUBPBS = SUBPBS / 2         CURLVL = CURLVL + 1         GO TO 80      END IF**     end while**     Re-merge the eigenvalues/vectors which were deflated at the final*     merge step.*      IF( ICOMPQ.EQ.1 ) THEN         DO 100 I = 1, N            J = IWORK( INDXQ+I )            WORK( I ) = D( J )            CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )  100    CONTINUE         CALL DCOPY( N, WORK, 1, D, 1 )      ELSE IF( ICOMPQ.EQ.2 ) THEN         DO 110 I = 1, N            J = IWORK( INDXQ+I )            WORK( I ) = D( J )            CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )  110    CONTINUE         CALL DCOPY( N, WORK, 1, D, 1 )         CALL DLACPY( 'A














































', N, N, WORK( N+1 ), N, Q, LDQ )      ELSE         DO 120 I = 1, N            J = IWORK( INDXQ+I )            WORK( I ) = D( J )  120    CONTINUE         CALL DCOPY( N, WORK, 1, D, 1 )      END IF      GO TO 140*  130 CONTINUE      INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1*  140 CONTINUE      RETURN**     End of DLAED0*      END      SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,     $                   INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            CUTPNT, INFO, LDQ, N      DOUBLE PRECISION   RHO*     ..*     .. Array Arguments ..      INTEGER            INDXQ( * ), IWORK( * )      DOUBLE PRECISION   D( * ), Q( LDQ, * ), WORK( * )*     ..**  Purpose*  =======**  DLAED1 computes the updated eigensystem of a diagonal*  matrix after modification by a rank-one symmetric matrix.  This*  routine is used only for the eigenproblem which requires all*  eigenvalues and eigenvectors of a tridiagonal matrix.  DLAED7 handles*  the case in which eigenvalues only or eigenvalues and eigenvectors*  of a full symmetric matrix (which was reduced to tridiagonal form)*  are desired.**    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
*     where Z = Q
































































































'u, u is a vector of length N with ones in the*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.**     The eigenvectors of the original matrix are stored in Q, and the*     eigenvalues are in D.  The algorithm consists of three stages:**        The first stage consists of deflating the size of the problem*        when there are multiple eigenvalues or if there is a zero in*        the Z vector.  For each such occurence the dimension of the*        secular equation problem is reduced by one.  This stage is*        performed by the routine DLAED2.**        The second stage consists of calculating the updated*        eigenvalues. This is done by finding the roots of the secular*        equation via the routine DLAED4 (as called by DLAED3).*        This routine also calculates the eigenvectors of the current*        problem.**        The final stage consists of computing the updated eigenvectors*        directly using the updated eigenvalues.  The eigenvectors for*        the current problem are multiplied with the eigenvectors from*        the overall problem.**  Arguments*  =========**  N      (input) INTEGER*         The dimension of the symmetric tridiagonal matrix.  N >= 0.**  D      (input/output) DOUBLE PRECISION array, dimension (N)*         On entry, the eigenvalues of the rank-1-perturbed matrix.*         On exit, the eigenvalues of the repaired matrix.**  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N)*         On entry, the eigenvectors of the rank-1-perturbed matrix.*         On exit, the eigenvectors of the repaired tridiagonal matrix.**  LDQ    (input) INTEGER*         The leading dimension of the array Q.  LDQ >= max(1,N).**  INDXQ  (input/output) INTEGER array, dimension (N)*         On entry, the permutation which separately sorts the two*         subproblems in D into ascending order.*         On exit, the permutation which will reintegrate the*         subproblems back into sorted order,*         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.**  RHO    (input) DOUBLE PRECISION*         The subdiagonal entry used to create the rank-1 modification.**  CUTPNT (input) INTEGER*         The location of the last eigenvalue in the leading sub-matrix.*         min(1,N) <= CUTPNT <= N/2.**  WORK   (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)**  IWORK  (workspace) INTEGER array, dimension (4*N)**  INFO   (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.*          > 0:  if INFO = 1, an eigenvalue did not converge**  Further Details*  ===============**  Based on contributions by*     Jeff Rutter, Computer Science Division, University of California*     at Berkeley, USA*  Modified by Francoise Tisseur, University of Tennessee.**  =====================================================================**     .. Local Scalars ..      INTEGER            COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,     $                   IW, IZ, K, N1, N2, ZPP1*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( N.LT.0 ) THEN         INFO = -1      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN         INFO = -4      ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN         INFO = -7      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLAED1













































































































































































































































', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 )     $   RETURN**     The following values are integer pointers which indicate*     the portion of the workspace*     used by a particular array in DLAED2 and DLAED3.*      IZ = 1      IDLMDA = IZ + N      IW = IDLMDA + N      IQ2 = IW + N*      INDX = 1      INDXC = INDX + N      COLTYP = INDXC + N      INDXP = COLTYP + N***     Form the z-vector which consists of the last row of Q_1 and the*     first row of Q_2.*      CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )      ZPP1 = CUTPNT + 1      CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )**     Deflate eigenvalues.*      CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),     $             WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),     $             IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),     $             IWORK( COLTYP ), INFO )*      IF( INFO.NE.0 )     $   GO TO 20**     Solve Secular Equation.*      IF( K.NE.0 ) THEN         IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +     $        ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2         CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),     $                WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),     $                WORK( IW ), WORK( IS ), INFO )         IF( INFO.NE.0 )     $      GO TO 20**     Prepare the INDXQ sorting permutation.*         N1 = K         N2 = N - K         CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )      ELSE         DO 10 I = 1, N            INDXQ( I ) = I   10    CONTINUE      END IF*   20 CONTINUE      RETURN**     End of DLAED1*      END      SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,     $                   Q2, INDX, INDXC, INDXP, COLTYP, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     October 31, 1999**     .. Scalar Arguments ..      INTEGER            INFO, K, LDQ, N, N1      DOUBLE PRECISION   RHO*     ..*     .. Array Arguments ..      INTEGER            COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),     $                   INDXQ( * )      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),     $                   W( * ), Z( * )*     ..**  Purpose*  =======**  DLAED2 merges the two sets of eigenvalues together into a single*  sorted set.  Then it tries to deflate the size of the problem.*  There are two ways in which deflation can occur:  when two or more*  eigenvalues are close together or if there is a tiny entry in the*  Z vector.  For each such occurrence the order of the related secular*  equation problem is reduced by one.**  Arguments*  =========**  K      (output) INTEGER*         The number of non-deflated eigenvalues, and the order of the*         related secular equation. 0 <= K <=N.**  N      (input) INTEGER*         The dimension of the symmetric tridiagonal matrix.  N >= 0.**  N1     (input) INTEGER*         The location of the last eigenvalue in the leading sub-matrix.*         min(1,N) <= N1 <= N/2.**  D      (input/output) DOUBLE PRECISION array, dimension (N)*         On entry, D contains the eigenvalues of the two submatrices to*         be combined.*         On exit, D contains the trailing (N-K) updated eigenvalues*         (those which were deflated) sorted into increasing order.**  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)*         On entry, Q contains the eigenvectors of two submatrices in*         the two square blocks with corners at (1,1), (N1,N1)*         and (N1+1, N1+1), (N,N).*         On exit, Q contains the trailing (N-K) updated eigenvectors*         (those which were deflated) in its last N-K columns.**  LDQ    (input) INTEGER*         The leading dimension of the array Q.  LDQ >= max(1,N).**  INDXQ  (input/output) INTEGER array, dimension (N)*         The permutation which separately sorts the two sub-problems*         in D into ascending order.  Note that elements in the second*         half of this permutation must first have N1 added to their*         values. Destroyed on exit.**  RHO    (input/output) DOUBLE PRECISION*         On entry, the off-diagonal element associated with the rank-1*         cut which originally split the two submatrices which are now*         being recombined.*         On exit, RHO has been modified to the value required by*         DLAED3.**  Z      (input) DOUBLE PRECISION array, dimension (N)*         On entry, Z contains the updating vector (the last*         row of the first sub-eigenvector matrix and the first row of*         the second sub-eigenvector matrix).*         On exit, the contents of Z have been destroyed by the updating*         process.**  DLAMDA (output) DOUBLE PRECISION array, dimension (N)*         A copy of the first K eigenvalues which will be used by*         DLAED3 to form the secular equation.**  W      (output) DOUBLE PRECISION array, dimension (N)*         The first k values of the final deflation-altered z-vector*         which will be passed to DLAED3.**  Q2     (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)*         A copy of the first K eigenvectors which will be used by*         DLAED3 in a matrix multiply (DGEMM) to solve for the new*         eigenvectors.**  INDX   (workspace) INTEGER array, dimension (N)*         The permutation used to sort the contents of DLAMDA into*         ascending order.**  INDXC  (output) INTEGER array, dimension (N)*         The permutation used to arrange the columns of the deflated*         Q matrix into three groups:  the first group contains non-zero*         elements only at and above N1, the second contains*         non-zero elements only below N1, and the third is dense.**  INDXP  (workspace) INTEGER array, dimension (N)*         The permutation used to place deflated values of D at the end*         of the array.  INDXP(1:K) points to the nondeflated D-values*         and INDXP(K+1:N) points to the deflated eigenvalues.**  COLTYP (workspace/output) INTEGER array, dimension (N)*         During execution, a label which will indicate which of the*         following types a column in the Q2 matrix is:*         1 : non-zero in the upper half only;*         2 : dense;*         3 : non-zero in the lower half only;*         4 : deflated.*         On exit, COLTYP(i) is the number of columns of type i,*         for i=1 to 4 only.**  INFO   (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  Based on contributions by*     Jeff Rutter, Computer Science Division, University of California*     at Berkeley, USA*  Modified by Francoise Tisseur, University of Tennessee.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   MONE, ZERO, ONE, TWO, EIGHT      PARAMETER          ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,     $                   TWO = 2.0D0, EIGHT = 8.0D0 )*     ..*     .. Local Arrays ..      INTEGER            CTOT( 4 ), PSM( 4 )*     ..*     .. Local Scalars ..      INTEGER            CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,     $                   N2, NJ, PJ      DOUBLE PRECISION   C, EPS, S, T, TAU, TOL*     ..*     .. External Functions ..      INTEGER            IDAMAX      DOUBLE PRECISION   DLAMCH, DLAPY2      EXTERNAL           IDAMAX, DLAMCH, DLAPY2*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN, SQRT*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN         INFO = -6      ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN         INFO = -3      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLAED2













































', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 )     $   RETURN*      N2 = N - N1      N1P1 = N1 + 1*      IF( RHO.LT.ZERO ) THEN         CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )      END IF**     Normalize z so that norm(z) = 1.  Since z is the concatenation of*     two normalized vectors, norm2(z) = sqrt(2).*      T = ONE / SQRT( TWO )      CALL DSCAL( N, T, Z, 1 )**     RHO = ABS( norm(z)**2 * RHO )*      RHO = ABS( TWO*RHO )**     Sort the eigenvalues into increasing order*      DO 10 I = N1P1, N         INDXQ( I ) = INDXQ( I ) + N1   10 CONTINUE**     re-integrate the deflated parts from the last pass*      DO 20 I = 1, N         DLAMDA( I ) = D( INDXQ( I ) )   20 CONTINUE      CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )      DO 30 I = 1, N         INDX( I ) = INDXQ( INDXC( I ) )   30 CONTINUE**     Calculate the allowable deflation tolerance*      IMAX = IDAMAX( N, Z, 1 )      JMAX = IDAMAX( N, D, 1 )      EPS = DLAMCH( 'Epsilon















' )      TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )**     If the rank-1 modifier is small enough, no more needs to be done*     except to reorganize Q so that its columns correspond with the*     elements in D.*      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN         K = 0         IQ2 = 1         DO 40 J = 1, N            I = INDX( J )            CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )            DLAMDA( J ) = D( I )            IQ2 = IQ2 + N   40    CONTINUE         CALL DLACPY( 'A




































































































































', N, N, Q2, N, Q, LDQ )         CALL DCOPY( N, DLAMDA, 1, D, 1 )         GO TO 190      END IF**     If there are multiple eigenvalues then the problem deflates.  Here*     the number of equal eigenvalues are found.  As each equal*     eigenvalue is found, an elementary reflector is computed to rotate*     the corresponding eigensubspace so that the corresponding*     components of Z are zero in this new basis.*      DO 50 I = 1, N1         COLTYP( I ) = 1   50 CONTINUE      DO 60 I = N1P1, N         COLTYP( I ) = 3   60 CONTINUE**      K = 0      K2 = N + 1      DO 70 J = 1, N         NJ = INDX( J )         IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN**           Deflate due to small z component.*            K2 = K2 - 1            COLTYP( NJ ) = 4            INDXP( K2 ) = NJ            IF( J.EQ.N )     $         GO TO 100         ELSE            PJ = NJ            GO TO 80         END IF   70 CONTINUE   80 CONTINUE      J = J + 1      NJ = INDX( J )      IF( J.GT.N )     $   GO TO 100      IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN**        Deflate due to small z component.*         K2 = K2 - 1         COLTYP( NJ ) = 4         INDXP( K2 ) = NJ      ELSE**        Check if eigenvalues are close enough to allow deflation.*         S = Z( PJ )         C = Z( NJ )**        Find sqrt(a**2+b**2) without overflow or*        destructive underflow.*         TAU = DLAPY2( C, S )         T = D( NJ ) - D( PJ )         C = C / TAU         S = -S / TAU         IF( ABS( T*C*S ).LE.TOL ) THEN**           Deflation is possible.*            Z( NJ ) = TAU            Z( PJ ) = ZERO            IF( COLTYP( NJ ).NE.COLTYP( PJ ) )     $         COLTYP( NJ ) = 2            COLTYP( PJ ) = 4            CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )            T = D( PJ )*C**2 + D( NJ )*S**2            D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2            D( PJ ) = T            K2 = K2 - 1            I = 1   90       CONTINUE            IF( K2+I.LE.N ) THEN               IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN                  INDXP( K2+I-1 ) = INDXP( K2+I )                  INDXP( K2+I ) = PJ                  I = I + 1                  GO TO 90               ELSE                  INDXP( K2+I-1 ) = PJ               END IF            ELSE               INDXP( K2+I-1 ) = PJ            END IF            PJ = NJ         ELSE            K = K + 1            DLAMDA( K ) = D( PJ )            W( K ) = Z( PJ )            INDXP( K ) = PJ            PJ = NJ         END IF      END IF      GO TO 80  100 CONTINUE**     Record the last eigenvalue.*      K = K + 1      DLAMDA( K ) = D( PJ )      W( K ) = Z( PJ )      INDXP( K ) = PJ**     Count up the total number of the various types of columns, then*     form a permutation which positions the four column types into*     four uniform groups (although one or more of these groups may be*     empty).*      DO 110 J = 1, 4         CTOT( J ) = 0  110 CONTINUE      DO 120 J = 1, N         CT = COLTYP( J )         CTOT( CT ) = CTOT( CT ) + 1  120 CONTINUE**     PSM(*) = Position in SubMatrix (of types 1 through 4)*      PSM( 1 ) = 1      PSM( 2 ) = 1 + CTOT( 1 )      PSM( 3 ) = PSM( 2 ) + CTOT( 2 )      PSM( 4 ) = PSM( 3 ) + CTOT( 3 )      K = N - CTOT( 4 )**     Fill out the INDXC array so that the permutation which it induces*     will place all type-1 columns first, all type-2 columns next,*     then all type-3's, and finally all type-4























































's.*      DO 130 J = 1, N         JS = INDXP( J )         CT = COLTYP( JS )         INDX( PSM( CT ) ) = JS         INDXC( PSM( CT ) ) = J         PSM( CT ) = PSM( CT ) + 1  130 CONTINUE**     Sort the eigenvalues and corresponding eigenvectors into DLAMDA*     and Q2 respectively.  The eigenvalues/vectors which were not*     deflated go into the first K slots of DLAMDA and Q2 respectively,*     while those which were deflated go into the last N - K slots.*      I = 1      IQ1 = 1      IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1      DO 140 J = 1, CTOT( 1 )         JS = INDX( I )         CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )         Z( I ) = D( JS )         I = I + 1         IQ1 = IQ1 + N1  140 CONTINUE*      DO 150 J = 1, CTOT( 2 )         JS = INDX( I )         CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )         CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )         Z( I ) = D( JS )         I = I + 1         IQ1 = IQ1 + N1         IQ2 = IQ2 + N2  150 CONTINUE*      DO 160 J = 1, CTOT( 3 )         JS = INDX( I )         CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )         Z( I ) = D( JS )         I = I + 1         IQ2 = IQ2 + N2  160 CONTINUE*      IQ1 = IQ2      DO 170 J = 1, CTOT( 4 )         JS = INDX( I )         CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )         IQ2 = IQ2 + N         Z( I ) = D( JS )         I = I + 1  170 CONTINUE**     The deflated eigenvalues and their corresponding vectors go back*     into the last N - K slots of D and Q respectively.*      CALL DLACPY( 'A


































































































































































', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )      CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )**     Copy CTOT into COLTYP for referencing in DLAED3.*      DO 180 J = 1, 4         COLTYP( J ) = CTOT( J )  180 CONTINUE*  190 CONTINUE      RETURN**     End of DLAED2*      END      SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,     $                   CTOT, W, S, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,*     Courant Institute, NAG Ltd., and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            INFO, K, LDQ, N, N1      DOUBLE PRECISION   RHO*     ..*     .. Array Arguments ..      INTEGER            CTOT( * ), INDX( * )      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),     $                   S( * ), W( * )*     ..**  Purpose*  =======**  DLAED3 finds the roots of the secular equation, as defined by the*  values in D, W, and RHO, between 1 and K.  It makes the*  appropriate calls to DLAED4 and then updates the eigenvectors by*  multiplying the matrix of eigenvectors of the pair of eigensystems*  being combined by the matrix of eigenvectors of the K-by-K system*  which is solved here.**  This code makes very mild assumptions about floating point*  arithmetic. It will work on machines with a guard digit in*  add/subtract, or on those binary machines without guard digits*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.*  It could conceivably fail on hexadecimal or decimal machines*  without guard digits, but we know of none.**  Arguments*  =========**  K       (input) INTEGER*          The number of terms in the rational function to be solved by*          DLAED4.  K >= 0.**  N       (input) INTEGER*          The number of rows and columns in the Q matrix.*          N >= K (deflation may result in N>K).**  N1      (input) INTEGER*          The location of the last eigenvalue in the leading submatrix.*          min(1,N) <= N1 <= N/2.**  D       (output) DOUBLE PRECISION array, dimension (N)*          D(I) contains the updated eigenvalues for*          1 <= I <= K.**  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)*          Initially the first K columns are used as workspace.*          On output the columns 1 to K contain*          the updated eigenvectors.**  LDQ     (input) INTEGER*          The leading dimension of the array Q.  LDQ >= max(1,N).**  RHO     (input) DOUBLE PRECISION*          The value of the parameter in the rank one update equation.*          RHO >= 0 required.**  DLAMDA  (input/output) DOUBLE PRECISION array, dimension (K)*          The first K elements of this array contain the old roots*          of the deflated updating problem.  These are the poles*          of the secular equation. May be changed on output by*          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,*          Cray-2, or Cray C-90, as described above.**  Q2      (input) DOUBLE PRECISION array, dimension (LDQ2, N)*          The first K columns of this matrix contain the non-deflated*          eigenvectors for the split problem.**  INDX    (input) INTEGER array, dimension (N)*          The permutation used to arrange the columns of the deflated*          Q matrix into three groups (see DLAED2).*          The rows of the eigenvectors found by DLAED4 must be likewise*          permuted before the matrix multiply can take place.**  CTOT    (input) INTEGER array, dimension (4)*          A count of the total number of the various types of columns*          in Q, as described in INDX.  The fourth column type is any*          column which has been deflated.**  W       (input/output) DOUBLE PRECISION array, dimension (K)*          The first K elements of this array contain the components*          of the deflation-adjusted updating vector. Destroyed on*          output.**  S       (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K*          Will contain the eigenvectors of the repaired matrix which*          will be multiplied by the previously accumulated eigenvectors*          to update the system.**  LDS     (input) INTEGER*          The leading dimension of S.  LDS >= max(1,K).**  INFO    (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.*          > 0:  if INFO = 1, an eigenvalue did not converge**  Further Details*  ===============**  Based on contributions by*     Jeff Rutter, Computer Science Division, University of California*     at Berkeley, USA*  Modified by Francoise Tisseur, University of Tennessee.**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )*     ..*     .. Local Scalars ..      INTEGER            I, II, IQ2, J, N12, N2, N23      DOUBLE PRECISION   TEMP*     ..*     .. External Functions ..      DOUBLE PRECISION   DLAMC3, DNRM2      EXTERNAL           DLAMC3, DNRM2*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, SIGN, SQRT*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( K.LT.0 ) THEN         INFO = -1      ELSE IF( N.LT.K ) THEN         INFO = -2      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN         INFO = -6      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLAED3




























































































', -INFO )         RETURN      END IF**     Quick return if possible*      IF( K.EQ.0 )     $   RETURN**     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can*     be computed with high relative accuracy (barring over/underflow).*     This is a problem on machines without a guard digit in*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),*     which on any of these machines zeros out the bottommost*     bit of DLAMDA(I) if it is 1; this makes the subsequent*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation*     occurs. On binary machines with a guard digit (almost all*     machines) it does not change DLAMDA(I) at all. On hexadecimal*     and decimal machines with a guard digit, it slightly*     changes the bottommost bits of DLAMDA(I). It does not account*     for hexadecimal or decimal machines without guard digits*     (we know of none). We use a subroutine call to compute*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating*     this code.*      DO 10 I = 1, K         DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )   10 CONTINUE*      DO 20 J = 1, K         CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )**        If the zero finder fails, the computation is terminated.*         IF( INFO.NE.0 )     $      GO TO 120   20 CONTINUE*      IF( K.EQ.1 )     $   GO TO 110      IF( K.EQ.2 ) THEN         DO 30 J = 1, K            W( 1 ) = Q( 1, J )            W( 2 ) = Q( 2, J )            II = INDX( 1 )            Q( 1, J ) = W( II )            II = INDX( 2 )            Q( 2, J ) = W( II )   30    CONTINUE         GO TO 110      END IF**     Compute updated W.*      CALL DCOPY( K, W, 1, S, 1 )**     Initialize W(I) = Q(I,I)*      CALL DCOPY( K, Q, LDQ+1, W, 1 )      DO 60 J = 1, K         DO 40 I = 1, J - 1            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )   40    CONTINUE         DO 50 I = J + 1, K            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )   50    CONTINUE   60 CONTINUE      DO 70 I = 1, K         W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )   70 CONTINUE**     Compute eigenvectors of the modified rank-1 modification.*      DO 100 J = 1, K         DO 80 I = 1, K            S( I ) = W( I ) / Q( I, J )   80    CONTINUE         TEMP = DNRM2( K, S, 1 )         DO 90 I = 1, K            II = INDX( I )            Q( I, J ) = S( II ) / TEMP   90    CONTINUE  100 CONTINUE**     Compute the updated eigenvectors.*  110 CONTINUE*      N2 = N - N1      N12 = CTOT( 1 ) + CTOT( 2 )      N23 = CTOT( 2 ) + CTOT( 3 )*      CALL DLACPY( 'A


', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )      IQ2 = N1*N12 + 1      IF( N23.NE.0 ) THEN         CALL DGEMM( 'N', 'N


', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,     $               ZERO, Q( N1+1, 1 ), LDQ )      ELSE         CALL DLASET( 'A


', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )      END IF*      CALL DLACPY( 'A

', N12, K, Q, LDQ, S, N12 )      IF( N12.NE.0 ) THEN         CALL DGEMM( 'N', 'N


', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,     $               LDQ )      ELSE         CALL DLASET( 'A






















































































































































', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )      END IF**  120 CONTINUE      RETURN**     End of DLAED3*      END      SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,*     Courant Institute, NAG Ltd., and Rice University*     December 23, 1999**     .. Scalar Arguments ..      INTEGER            I, INFO, N      DOUBLE PRECISION   DLAM, RHO*     ..*     .. Array Arguments ..      DOUBLE PRECISION   D( * ), DELTA( * ), Z( * )*     ..**  Purpose*  =======**  This subroutine computes the I-th updated eigenvalue of a symmetric*  rank-one modification to a diagonal matrix whose elements are*  given in the array d, and that**             D(i) < D(j)  for  i < j**  and that RHO > 0.  This is arranged by the calling routine, and is*  no loss in generality.  The rank-one modified system is thus**             diag( D )  +  RHO *  Z * Z_transpose.**  where we assume the Euclidean norm of Z is 1.**  The method consists of approximating the rational functions in the*  secular equation by simpler interpolating rational functions.**  Arguments*  =========**  N      (input) INTEGER*         The length of all arrays.**  I      (input) INTEGER*         The index of the eigenvalue to be computed.  1 <= I <= N.**  D      (input) DOUBLE PRECISION array, dimension (N)*         The original eigenvalues.  It is assumed that they are in*         order, D(I) < D(J)  for I < J.**  Z      (input) DOUBLE PRECISION array, dimension (N)*         The components of the updating vector.**  DELTA  (output) DOUBLE PRECISION array, dimension (N)*         If N .ne. 1, DELTA contains (D(j) - lambda_I) in its  j-th*         component.  If N = 1, then DELTA(1) = 1.  The vector DELTA*         contains the information necessary to construct the*         eigenvectors.**  RHO    (input) DOUBLE PRECISION*         The scalar in the symmetric updating formula.**  DLAM   (output) DOUBLE PRECISION*         The computed lambda_I, the I-th updated eigenvalue.**  INFO   (output) INTEGER*         = 0:  successful exit*         > 0:  if INFO = 1, the updating process failed.**  Internal Parameters*  ===================**  Logical variable ORGATI (origin-at-i?) is used for distinguishing*  whether D(i) or D(i+1) is treated as the origin.**            ORGATI = .true.    origin at i*            ORGATI = .false.   origin at i+1**   Logical variable SWTCH3 (switch-for-3-poles?) is for noting*   if we are working with THREE poles!**   MAXIT is the maximum number of iterations allowed for each*   eigenvalue.**  Further Details*  ===============**  Based on contributions by*     Ren-Cang Li, Computer Science Division, University of California*     at Berkeley, USA**  =====================================================================**     .. Parameters ..      INTEGER            MAXIT      PARAMETER          ( MAXIT = 30 )      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,     $                   THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,     $                   TEN = 10.0D0 )*     ..*     .. Local Scalars ..      LOGICAL            ORGATI, SWTCH, SWTCH3      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER      DOUBLE PRECISION   A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,     $                   EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,     $                   RHOINV, TAU, TEMP, TEMP1, W*     ..*     .. Local Arrays ..      DOUBLE PRECISION   ZZ( 3 )*     ..*     .. External Functions ..      DOUBLE PRECISION   DLAMCH      EXTERNAL           DLAMCH*     ..*     .. External Subroutines ..      EXTERNAL           DLAED5, DLAED6*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN, SQRT*     ..*     .. Executable Statements ..**     Since this routine is called in an inner loop, we do no argument*     checking.**     Quick return for N=1 and 2.*      INFO = 0      IF( N.EQ.1 ) THEN**         Presumably, I=1 upon entry*         DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )         DELTA( 1 ) = ONE         RETURN      END IF      IF( N.EQ.2 ) THEN         CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )         RETURN      END IF**     Compute machine epsilon*      EPS = DLAMCH( 'Epsilon













































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































' )      RHOINV = ONE / RHO**     The case I = N*      IF( I.EQ.N ) THEN**        Initialize some basic variables*         II = N - 1         NITER = 1**        Calculate initial guess*         MIDPT = RHO / TWO**        If ||Z||_2 is not one, then TEMP should be set to*        RHO * ||Z||_2^2 / TWO*         DO 10 J = 1, N            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT   10    CONTINUE*         PSI = ZERO         DO 20 J = 1, N - 2            PSI = PSI + Z( J )*Z( J ) / DELTA( J )   20    CONTINUE*         C = RHOINV + PSI         W = C + Z( II )*Z( II ) / DELTA( II ) +     $       Z( N )*Z( N ) / DELTA( N )*         IF( W.LE.ZERO ) THEN            TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +     $             Z( N )*Z( N ) / RHO            IF( C.LE.TEMP ) THEN               TAU = RHO            ELSE               DEL = D( N ) - D( N-1 )               A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )               B = Z( N )*Z( N )*DEL               IF( A.LT.ZERO ) THEN                  TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )               ELSE                  TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )               END IF            END IF**           It can be proved that*               D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO*            DLTLB = MIDPT            DLTUB = RHO         ELSE            DEL = D( N ) - D( N-1 )            A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )            B = Z( N )*Z( N )*DEL            IF( A.LT.ZERO ) THEN               TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )            ELSE               TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )            END IF**           It can be proved that*               D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2*            DLTLB = ZERO            DLTUB = MIDPT         END IF*         DO 30 J = 1, N            DELTA( J ) = ( D( J )-D( I ) ) - TAU   30    CONTINUE**        Evaluate PSI and the derivative DPSI*         DPSI = ZERO         PSI = ZERO         ERRETM = ZERO         DO 40 J = 1, II            TEMP = Z( J ) / DELTA( J )            PSI = PSI + Z( J )*TEMP            DPSI = DPSI + TEMP*TEMP            ERRETM = ERRETM + PSI   40    CONTINUE         ERRETM = ABS( ERRETM )**        Evaluate PHI and the derivative DPHI*         TEMP = Z( N ) / DELTA( N )         PHI = Z( N )*TEMP         DPHI = TEMP*TEMP         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +     $            ABS( TAU )*( DPSI+DPHI )*         W = RHOINV + PHI + PSI**        Test for convergence*         IF( ABS( W ).LE.EPS*ERRETM ) THEN            DLAM = D( I ) + TAU            GO TO 250         END IF*         IF( W.LE.ZERO ) THEN            DLTLB = MAX( DLTLB, TAU )         ELSE            DLTUB = MIN( DLTUB, TAU )         END IF**        Calculate the new step*         NITER = NITER + 1         C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI         A = ( DELTA( N-1 )+DELTA( N ) )*W -     $       DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )         B = DELTA( N-1 )*DELTA( N )*W         IF( C.LT.ZERO )     $      C = ABS( C )         IF( C.EQ.ZERO ) THEN*          ETA = B/A*           ETA = RHO - TAU            ETA = DLTUB - TAU         ELSE IF( A.GE.ZERO ) THEN            ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )         ELSE            ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )         END IF**        Note, eta should be positive if w is negative, and*        eta should be negative otherwise. However,*        if for some reason caused by roundoff, eta*w > 0,*        we simply use one Newton step instead. This way*        will guarantee eta*w < 0.*         IF( W*ETA.GT.ZERO )     $      ETA = -W / ( DPSI+DPHI )         TEMP = TAU + ETA         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN            IF( W.LT.ZERO ) THEN               ETA = ( DLTUB-TAU ) / TWO            ELSE               ETA = ( DLTLB-TAU ) / TWO            END IF         END IF         DO 50 J = 1, N            DELTA( J ) = DELTA( J ) - ETA   50    CONTINUE*         TAU = TAU + ETA**        Evaluate PSI and the derivative DPSI*         DPSI = ZERO         PSI = ZERO         ERRETM = ZERO         DO 60 J = 1, II            TEMP = Z( J ) / DELTA( J )            PSI = PSI + Z( J )*TEMP            DPSI = DPSI + TEMP*TEMP            ERRETM = ERRETM + PSI   60    CONTINUE         ERRETM = ABS( ERRETM )**        Evaluate PHI and the derivative DPHI*         TEMP = Z( N ) / DELTA( N )         PHI = Z( N )*TEMP         DPHI = TEMP*TEMP         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +     $            ABS( TAU )*( DPSI+DPHI )*         W = RHOINV + PHI + PSI**        Main loop to update the values of the array   DELTA*         ITER = NITER + 1*         DO 90 NITER = ITER, MAXIT**           Test for convergence*            IF( ABS( W ).LE.EPS*ERRETM ) THEN               DLAM = D( I ) + TAU               GO TO 250            END IF*            IF( W.LE.ZERO ) THEN               DLTLB = MAX( DLTLB, TAU )            ELSE               DLTUB = MIN( DLTUB, TAU )            END IF**           Calculate the new step*            C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI            A = ( DELTA( N-1 )+DELTA( N ) )*W -     $          DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )            B = DELTA( N-1 )*DELTA( N )*W            IF( A.GE.ZERO ) THEN               ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )            ELSE               ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )            END IF**           Note, eta should be positive if w is negative, and*           eta should be negative otherwise. However,*           if for some reason caused by roundoff, eta*w > 0,*           we simply use one Newton step instead. This way*           will guarantee eta*w < 0.*            IF( W*ETA.GT.ZERO )     $         ETA = -W / ( DPSI+DPHI )            TEMP = TAU + ETA            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN               IF( W.LT.ZERO ) THEN                  ETA = ( DLTUB-TAU ) / TWO               ELSE                  ETA = ( DLTLB-TAU ) / TWO               END IF            END IF            DO 70 J = 1, N               DELTA( J ) = DELTA( J ) - ETA   70       CONTINUE*            TAU = TAU + ETA**           Evaluate PSI and the derivative DPSI*            DPSI = ZERO            PSI = ZERO            ERRETM = ZERO            DO 80 J = 1, II               TEMP = Z( J ) / DELTA( J )               PSI = PSI + Z( J )*TEMP               DPSI = DPSI + TEMP*TEMP               ERRETM = ERRETM + PSI   80       CONTINUE            ERRETM = ABS( ERRETM )**           Evaluate PHI and the derivative DPHI*            TEMP = Z( N ) / DELTA( N )            PHI = Z( N )*TEMP            DPHI = TEMP*TEMP            ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +     $               ABS( TAU )*( DPSI+DPHI )*            W = RHOINV + PHI + PSI   90    CONTINUE**        Return with INFO = 1, NITER = MAXIT and not converged*         INFO = 1         DLAM = D( I ) + TAU         GO TO 250**        End for the case I = N*      ELSE**        The case for I < N*         NITER = 1         IP1 = I + 1**        Calculate initial guess*         DEL = D( IP1 ) - D( I )         MIDPT = DEL / TWO         DO 100 J = 1, N            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT  100    CONTINUE*         PSI = ZERO         DO 110 J = 1, I - 1            PSI = PSI + Z( J )*Z( J ) / DELTA( J )  110    CONTINUE*         PHI = ZERO         DO 120 J = N, I + 2, -1            PHI = PHI + Z( J )*Z( J ) / DELTA( J )  120    CONTINUE         C = RHOINV + PSI + PHI         W = C + Z( I )*Z( I ) / DELTA( I ) +     $       Z( IP1 )*Z( IP1 ) / DELTA( IP1 )*         IF( W.GT.ZERO ) THEN**           d(i)< the ith eigenvalue < (d(i)+d(i+1))/2**           We choose d(i) as origin.*            ORGATI = .TRUE.            A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )            B = Z( I )*Z( I )*DEL            IF( A.GT.ZERO ) THEN               TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )            ELSE               TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )            END IF            DLTLB = ZERO            DLTUB = MIDPT         ELSE**           (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)**           We choose d(i+1) as origin.*            ORGATI = .FALSE.            A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )            B = Z( IP1 )*Z( IP1 )*DEL            IF( A.LT.ZERO ) THEN               TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )            ELSE               TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )            END IF            DLTLB = -MIDPT            DLTUB = ZERO         END IF*         IF( ORGATI ) THEN            DO 130 J = 1, N               DELTA( J ) = ( D( J )-D( I ) ) - TAU  130       CONTINUE         ELSE            DO 140 J = 1, N               DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU  140       CONTINUE         END IF         IF( ORGATI ) THEN            II = I         ELSE            II = I + 1         END IF         IIM1 = II - 1         IIP1 = II + 1**        Evaluate PSI and the derivative DPSI*         DPSI = ZERO         PSI = ZERO         ERRETM = ZERO         DO 150 J = 1, IIM1            TEMP = Z( J ) / DELTA( J )            PSI = PSI + Z( J )*TEMP            DPSI = DPSI + TEMP*TEMP            ERRETM = ERRETM + PSI  150    CONTINUE         ERRETM = ABS( ERRETM )**        Evaluate PHI and the derivative DPHI*         DPHI = ZERO         PHI = ZERO         DO 160 J = N, IIP1, -1            TEMP = Z( J ) / DELTA( J )            PHI = PHI + Z( J )*TEMP            DPHI = DPHI + TEMP*TEMP            ERRETM = ERRETM + PHI  160    CONTINUE*         W = RHOINV + PHI + PSI**        W is the value of the secular function with*        its ii-th element removed.*         SWTCH3 = .FALSE.         IF( ORGATI ) THEN            IF( W.LT.ZERO )     $         SWTCH3 = .TRUE.         ELSE            IF( W.GT.ZERO )     $         SWTCH3 = .TRUE.         END IF         IF( II.EQ.1 .OR. II.EQ.N )     $      SWTCH3 = .FALSE.*         TEMP = Z( II ) / DELTA( II )         DW = DPSI + DPHI + TEMP*TEMP         TEMP = Z( II )*TEMP         W = W + TEMP         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +     $            THREE*ABS( TEMP ) + ABS( TAU )*DW**        Test for convergence*         IF( ABS( W ).LE.EPS*ERRETM ) THEN            IF( ORGATI ) THEN               DLAM = D( I ) + TAU            ELSE               DLAM = D( IP1 ) + TAU            END IF            GO TO 250         END IF*         IF( W.LE.ZERO ) THEN            DLTLB = MAX( DLTLB, TAU )         ELSE            DLTUB = MIN( DLTUB, TAU )         END IF**        Calculate the new step*         NITER = NITER + 1         IF( .NOT.SWTCH3 ) THEN            IF( ORGATI ) THEN               C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*     $             ( Z( I ) / DELTA( I ) )**2            ELSE               C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*     $             ( Z( IP1 ) / DELTA( IP1 ) )**2            END IF            A = ( DELTA( I )+DELTA( IP1 ) )*W -     $          DELTA( I )*DELTA( IP1 )*DW            B = DELTA( I )*DELTA( IP1 )*W            IF( C.EQ.ZERO ) THEN               IF( A.EQ.ZERO ) THEN                  IF( ORGATI ) THEN                     A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*     $                   ( DPSI+DPHI )                  ELSE                     A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*     $                   ( DPSI+DPHI )                  END IF               END IF               ETA = B / A            ELSE IF( A.LE.ZERO ) THEN               ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )            ELSE               ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )            END IF         ELSE**           Interpolation using THREE most relevant poles*            TEMP = RHOINV + PSI + PHI            IF( ORGATI ) THEN               TEMP1 = Z( IIM1 ) / DELTA( IIM1 )               TEMP1 = TEMP1*TEMP1               C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -     $             ( D( IIM1 )-D( IIP1 ) )*TEMP1               ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )               ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*     $                   ( ( DPSI-TEMP1 )+DPHI )            ELSE               TEMP1 = Z( IIP1 ) / DELTA( IIP1 )               TEMP1 = TEMP1*TEMP1               C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -     $             ( D( IIP1 )-D( IIM1 ) )*TEMP1               ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*     $                   ( DPSI+( DPHI-TEMP1 ) )               ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )            END IF            ZZ( 2 ) = Z( II )*Z( II )            CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,     $                   INFO )            IF( INFO.NE.0 )     $         GO TO 250         END IF**        Note, eta should be positive if w is negative, and*        eta should be negative otherwise. However,*        if for some reason caused by roundoff, eta*w > 0,*        we simply use one Newton step instead. This way*        will guarantee eta*w < 0.*         IF( W*ETA.GE.ZERO )     $      ETA = -W / DW         TEMP = TAU + ETA         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN            IF( W.LT.ZERO ) THEN               ETA = ( DLTUB-TAU ) / TWO            ELSE               ETA = ( DLTLB-TAU ) / TWO            END IF         END IF*         PREW = W*  170    CONTINUE         DO 180 J = 1, N            DELTA( J ) = DELTA( J ) - ETA  180    CONTINUE**        Evaluate PSI and the derivative DPSI*         DPSI = ZERO         PSI = ZERO         ERRETM = ZERO         DO 190 J = 1, IIM1            TEMP = Z( J ) / DELTA( J )            PSI = PSI + Z( J )*TEMP            DPSI = DPSI + TEMP*TEMP            ERRETM = ERRETM + PSI  190    CONTINUE         ERRETM = ABS( ERRETM )**        Evaluate PHI and the derivative DPHI*         DPHI = ZERO         PHI = ZERO         DO 200 J = N, IIP1, -1            TEMP = Z( J ) / DELTA( J )            PHI = PHI + Z( J )*TEMP            DPHI = DPHI + TEMP*TEMP            ERRETM = ERRETM + PHI  200    CONTINUE*         TEMP = Z( II ) / DELTA( II )         DW = DPSI + DPHI + TEMP*TEMP         TEMP = Z( II )*TEMP         W = RHOINV + PHI + PSI + TEMP         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +     $            THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW*         SWTCH = .FALSE.         IF( ORGATI ) THEN            IF( -W.GT.ABS( PREW ) / TEN )     $         SWTCH = .TRUE.         ELSE            IF( W.GT.ABS( PREW ) / TEN )     $         SWTCH = .TRUE.         END IF*         TAU = TAU + ETA**        Main loop to update the values of the array   DELTA*         ITER = NITER + 1*         DO 240 NITER = ITER, MAXIT**           Test for convergence*            IF( ABS( W ).LE.EPS*ERRETM ) THEN               IF( ORGATI ) THEN                  DLAM = D( I ) + TAU               ELSE                  DLAM = D( IP1 ) + TAU               END IF               GO TO 250            END IF*            IF( W.LE.ZERO ) THEN               DLTLB = MAX( DLTLB, TAU )            ELSE               DLTUB = MIN( DLTUB, TAU )            END IF**           Calculate the new step*            IF( .NOT.SWTCH3 ) THEN               IF( .NOT.SWTCH ) THEN                  IF( ORGATI ) THEN                     C = W - DELTA( IP1 )*DW -     $                   ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2                  ELSE                     C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*     $                   ( Z( IP1 ) / DELTA( IP1 ) )**2                  END IF               ELSE                  TEMP = Z( II ) / DELTA( II )                  IF( ORGATI ) THEN                     DPSI = DPSI + TEMP*TEMP                  ELSE                     DPHI = DPHI + TEMP*TEMP                  END IF                  C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI               END IF               A = ( DELTA( I )+DELTA( IP1 ) )*W -     $             DELTA( I )*DELTA( IP1 )*DW               B = DELTA( I )*DELTA( IP1 )*W               IF( C.EQ.ZERO ) THEN                  IF( A.EQ.ZERO ) THEN                     IF( .NOT.SWTCH ) THEN                        IF( ORGATI ) THEN                           A = Z( I )*Z( I ) + DELTA( IP1 )*     $                         DELTA( IP1 )*( DPSI+DPHI )                        ELSE                           A = Z( IP1 )*Z( IP1 ) +     $                         DELTA( I )*DELTA( I )*( DPSI+DPHI )                        END IF                     ELSE                        A = DELTA( I )*DELTA( I )*DPSI +     $                      DELTA( IP1 )*DELTA( IP1 )*DPHI                     END IF                  END IF                  ETA = B / A               ELSE IF( A.LE.ZERO ) THEN                  ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )               ELSE                  ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )               END IF            ELSE**              Interpolation using THREE most relevant poles*               TEMP = RHOINV + PSI + PHI               IF( SWTCH ) THEN                  C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI                  ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI                  ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI               ELSE                  IF( ORGATI ) THEN                     TEMP1 = Z( IIM1 ) / DELTA( IIM1 )                     TEMP1 = TEMP1*TEMP1                     C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -     $                   ( D( IIM1 )-D( IIP1 ) )*TEMP1                     ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )                     ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*     $                         ( ( DPSI-TEMP1 )+DPHI )                  ELSE                     TEMP1 = Z( IIP1 ) / DELTA( IIP1 )                     TEMP1 = TEMP1*TEMP1                     C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -     $                   ( D( IIP1 )-D( IIM1 ) )*TEMP1                     ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*     $                         ( DPSI+( DPHI-TEMP1 ) )                     ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )                  END IF               END IF               CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,     $                      INFO )               IF( INFO.NE.0 )     $            GO TO 250            END IF**           Note, eta should be positive if w is negative, and*           eta should be negative otherwise. However,*           if for some reason caused by roundoff, eta*w > 0,*           we simply use one Newton step instead. This way*           will guarantee eta*w < 0.*            IF( W*ETA.GE.ZERO )     $         ETA = -W / DW            TEMP = TAU + ETA            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN               IF( W.LT.ZERO ) THEN                  ETA = ( DLTUB-TAU ) / TWO               ELSE                  ETA = ( DLTLB-TAU ) / TWO               END IF            END IF*            DO 210 J = 1, N               DELTA( J ) = DELTA( J ) - ETA  210       CONTINUE*            TAU = TAU + ETA            PREW = W**           Evaluate PSI and the derivative DPSI*            DPSI = ZERO            PSI = ZERO            ERRETM = ZERO            DO 220 J = 1, IIM1               TEMP = Z( J ) / DELTA( J )               PSI = PSI + Z( J )*TEMP               DPSI = DPSI + TEMP*TEMP               ERRETM = ERRETM + PSI  220       CONTINUE            ERRETM = ABS( ERRETM )**           Evaluate PHI and the derivative DPHI*            DPHI = ZERO            PHI = ZERO            DO 230 J = N, IIP1, -1               TEMP = Z( J ) / DELTA( J )               PHI = PHI + Z( J )*TEMP               DPHI = DPHI + TEMP*TEMP               ERRETM = ERRETM + PHI  230       CONTINUE*            TEMP = Z( II ) / DELTA( II )            DW = DPSI + DPHI + TEMP*TEMP            TEMP = Z( II )*TEMP            W = RHOINV + PHI + PSI + TEMP            ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +     $               THREE*ABS( TEMP ) + ABS( TAU )*DW            IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )     $         SWTCH = .NOT.SWTCH*  240    CONTINUE**        Return with INFO = 1, NITER = MAXIT and not converged*         INFO = 1         IF( ORGATI ) THEN            DLAM = D( I ) + TAU         ELSE            DLAM = D( IP1 ) + TAU         END IF*      END IF*  250 CONTINUE*      RETURN**     End of DLAED4*      END      SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,*     Courant Institute, NAG Ltd., and Rice University*     September 30, 1994**     .. Scalar Arguments ..      INTEGER            I      DOUBLE PRECISION   DLAM, RHO*     ..*     .. Array Arguments ..      DOUBLE PRECISION   D( 2 ), DELTA( 2 ), Z( 2 )*     ..**  Purpose*  =======**  This subroutine computes the I-th eigenvalue of a symmetric rank-one*  modification of a 2-by-2 diagonal matrix**             diag( D )  +  RHO *  Z * transpose(Z) .**  The diagonal elements in the array D are assumed to satisfy**             D(i) < D(j)  for  i < j .**  We also assume RHO > 0 and that the Euclidean norm of the vector*  Z is one.**  Arguments*  =========**  I      (input) INTEGER*         The index of the eigenvalue to be computed.  I = 1 or I = 2.**  D      (input) DOUBLE PRECISION array, dimension (2)*         The original eigenvalues.  We assume D(1) < D(2).**  Z      (input) DOUBLE PRECISION array, dimension (2)*         The components of the updating vector.**  DELTA  (output) DOUBLE PRECISION array, dimension (2)*         The vector DELTA contains the information necessary*         to construct the eigenvectors.**  RHO    (input) DOUBLE PRECISION*         The scalar in the symmetric updating formula.**  DLAM   (output) DOUBLE PRECISION*         The computed lambda_I, the I-th updated eigenvalue.**  Further Details*  ===============**  Based on contributions by*     Ren-Cang Li, Computer Science Division, University of California*     at Berkeley, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,     $                   FOUR = 4.0D0 )*     ..*     .. Local Scalars ..      DOUBLE PRECISION   B, C, DEL, TAU, TEMP, W*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, SQRT*     ..*     .. Executable Statements ..*      DEL = D( 2 ) - D( 1 )      IF( I.EQ.1 ) THEN         W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL         IF( W.GT.ZERO ) THEN            B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )            C = RHO*Z( 1 )*Z( 1 )*DEL**           B > ZERO, always*            TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )            DLAM = D( 1 ) + TAU            DELTA( 1 ) = -Z( 1 ) / TAU            DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )         ELSE            B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )            C = RHO*Z( 2 )*Z( 2 )*DEL            IF( B.GT.ZERO ) THEN               TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )            ELSE               TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO            END IF            DLAM = D( 2 ) + TAU            DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )            DELTA( 2 ) = -Z( 2 ) / TAU         END IF         TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )         DELTA( 1 ) = DELTA( 1 ) / TEMP         DELTA( 2 ) = DELTA( 2 ) / TEMP      ELSE**     Now I=2*         B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )         C = RHO*Z( 2 )*Z( 2 )*DEL         IF( B.GT.ZERO ) THEN            TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO         ELSE            TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )         END IF         DLAM = D( 2 ) + TAU         DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )         DELTA( 2 ) = -Z( 2 ) / TAU         TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )         DELTA( 1 ) = DELTA( 1 ) / TEMP         DELTA( 2 ) = DELTA( 2 ) / TEMP      END IF      RETURN**     End OF DLAED5*      END      SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,*     Courant Institute, NAG Ltd., and Rice University*     June 30, 1999**     .. Scalar Arguments ..      LOGICAL            ORGATI      INTEGER            INFO, KNITER      DOUBLE PRECISION   FINIT, RHO, TAU*     ..*     .. Array Arguments ..      DOUBLE PRECISION   D( 3 ), Z( 3 )*     ..**  Purpose*  =======**  DLAED6 computes the positive or negative root (closest to the origin)*  of*                   z(1)        z(2)        z(3)*  f(x) =   rho + --------- + ---------- + ---------*                  d(1)-x      d(2)-x      d(3)-x**  It is assumed that**        if ORGATI = .true. the root is between d(2) and d(3);*        otherwise it is between d(1) and d(2)**  This routine will be called by DLAED4 when necessary. In most cases,*  the root sought is the smallest in magnitude, though it might not be*  in some extremely rare situations.**  Arguments*  =========**  KNITER       (input) INTEGER*               Refer to DLAED4 for its significance.**  ORGATI       (input) LOGICAL*               If ORGATI is true, the needed root is between d(2) and*               d(3); otherwise it is between d(1) and d(2).  See*               DLAED4 for further details.**  RHO          (input) DOUBLE PRECISION*               Refer to the equation f(x) above.**  D            (input) DOUBLE PRECISION array, dimension (3)*               D satisfies d(1) < d(2) < d(3).**  Z            (input) DOUBLE PRECISION array, dimension (3)*               Each of the elements in z must be positive.**  FINIT        (input) DOUBLE PRECISION*               The value of f at 0. It is more accurate than the one*               evaluated inside this routine (if someone wants to do*               so).**  TAU          (output) DOUBLE PRECISION*               The root of the equation f(x).**  INFO         (output) INTEGER*               = 0: successful exit*               > 0: if INFO = 1, failure to converge**  Further Details*  ===============**  Based on contributions by*     Ren-Cang Li, Computer Science Division, University of California*     at Berkeley, USA**  =====================================================================**     .. Parameters ..      INTEGER            MAXIT      PARAMETER          ( MAXIT = 20 )      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,     $                   THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )*     ..*     .. External Functions ..      DOUBLE PRECISION   DLAMCH      EXTERNAL           DLAMCH*     ..*     .. Local Arrays ..      DOUBLE PRECISION   DSCALE( 3 ), ZSCALE( 3 )*     ..*     .. Local Scalars ..      LOGICAL            FIRST, SCALE      INTEGER            I, ITER, NITER      DOUBLE PRECISION   A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,     $                   FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,     $                   SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4*     ..*     .. Save statement ..      SAVE               FIRST, SMALL1, SMINV1, SMALL2, SMINV2, EPS*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT*     ..*     .. Data statements ..      DATA               FIRST / .TRUE. /*     ..*     .. Executable Statements ..*      INFO = 0*      NITER = 1      TAU = ZERO      IF( KNITER.EQ.2 ) THEN         IF( ORGATI ) THEN            TEMP = ( D( 3 )-D( 2 ) ) / TWO            C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )            A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )            B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )         ELSE            TEMP = ( D( 1 )-D( 2 ) ) / TWO            C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )            A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )            B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )         END IF         TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )         A = A / TEMP         B = B / TEMP         C = C / TEMP         IF( C.EQ.ZERO ) THEN            TAU = B / A         ELSE IF( A.LE.ZERO ) THEN            TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )         ELSE            TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )         END IF         TEMP = RHO + Z( 1 ) / ( D( 1 )-TAU ) +     $          Z( 2 ) / ( D( 2 )-TAU ) + Z( 3 ) / ( D( 3 )-TAU )         IF( ABS( FINIT ).LE.ABS( TEMP ) )     $      TAU = ZERO      END IF**     On first call to routine, get machine parameters for*     possible scaling to avoid overflow*      IF( FIRST ) THEN         EPS = DLAMCH( 'Epsilon
' )         BASE = DLAMCH( 'Base
' )         SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin

























































































































































































' ) ) / LOG( BASE ) /     $            THREE ) )         SMINV1 = ONE / SMALL1         SMALL2 = SMALL1*SMALL1         SMINV2 = SMINV1*SMINV1         FIRST = .FALSE.      END IF**     Determine if scaling of inputs necessary to avoid overflow*     when computing 1/TEMP**3*      IF( ORGATI ) THEN         TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )      ELSE         TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )      END IF      SCALE = .FALSE.      IF( TEMP.LE.SMALL1 ) THEN         SCALE = .TRUE.         IF( TEMP.LE.SMALL2 ) THEN**        Scale up by power of radix nearest 1/SAFMIN**(2/3)*            SCLFAC = SMINV2            SCLINV = SMALL2         ELSE**        Scale up by power of radix nearest 1/SAFMIN**(1/3)*            SCLFAC = SMINV1            SCLINV = SMALL1         END IF**        Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)*         DO 10 I = 1, 3            DSCALE( I ) = D( I )*SCLFAC            ZSCALE( I ) = Z( I )*SCLFAC   10    CONTINUE         TAU = TAU*SCLFAC      ELSE**        Copy D and Z to DSCALE and ZSCALE*         DO 20 I = 1, 3            DSCALE( I ) = D( I )            ZSCALE( I ) = Z( I )   20    CONTINUE      END IF*      FC = ZERO      DF = ZERO      DDF = ZERO      DO 30 I = 1, 3         TEMP = ONE / ( DSCALE( I )-TAU )         TEMP1 = ZSCALE( I )*TEMP         TEMP2 = TEMP1*TEMP         TEMP3 = TEMP2*TEMP         FC = FC + TEMP1 / DSCALE( I )         DF = DF + TEMP2         DDF = DDF + TEMP3   30 CONTINUE      F = FINIT + TAU*FC*      IF( ABS( F ).LE.ZERO )     $   GO TO 60**        Iteration begins**     It is not hard to see that**           1) Iterations will go up monotonically*              if FINIT < 0;**           2) Iterations will go down monotonically*              if FINIT > 0.*      ITER = NITER + 1*      DO 50 NITER = ITER, MAXIT*         IF( ORGATI ) THEN            TEMP1 = DSCALE( 2 ) - TAU            TEMP2 = DSCALE( 3 ) - TAU         ELSE            TEMP1 = DSCALE( 1 ) - TAU            TEMP2 = DSCALE( 2 ) - TAU         END IF         A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF         B = TEMP1*TEMP2*F         C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF         TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )         A = A / TEMP         B = B / TEMP         C = C / TEMP         IF( C.EQ.ZERO ) THEN            ETA = B / A         ELSE IF( A.LE.ZERO ) THEN            ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )         ELSE            ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )         END IF         IF( F*ETA.GE.ZERO ) THEN            ETA = -F / DF         END IF*         TEMP = ETA + TAU         IF( ORGATI ) THEN            IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 3 ) )     $         ETA = ( DSCALE( 3 )-TAU ) / TWO            IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 2 ) )     $         ETA = ( DSCALE( 2 )-TAU ) / TWO         ELSE            IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 2 ) )     $         ETA = ( DSCALE( 2 )-TAU ) / TWO            IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 1 ) )     $         ETA = ( DSCALE( 1 )-TAU ) / TWO         END IF         TAU = TAU + ETA*         FC = ZERO         ERRETM = ZERO         DF = ZERO         DDF = ZERO         DO 40 I = 1, 3            TEMP = ONE / ( DSCALE( I )-TAU )            TEMP1 = ZSCALE( I )*TEMP            TEMP2 = TEMP1*TEMP            TEMP3 = TEMP2*TEMP            TEMP4 = TEMP1 / DSCALE( I )            FC = FC + TEMP4            ERRETM = ERRETM + ABS( TEMP4 )            DF = DF + TEMP2            DDF = DDF + TEMP3   40    CONTINUE         F = FINIT + TAU*FC         ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +     $            ABS( TAU )*DF         IF( ABS( F ).LE.EPS*ERRETM )     $      GO TO 60   50 CONTINUE      INFO = 1   60 CONTINUE**     Undo scaling*      IF( SCALE )     $   TAU = TAU*SCLINV      RETURN**     End of DLAED6*      END      SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,     $                   LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,     $                   PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,     $                   INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      INTEGER            CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,     $                   QSIZ, TLVLS      DOUBLE PRECISION   RHO*     ..*     .. Array Arguments ..      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),     $                   IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )      DOUBLE PRECISION   D( * ), GIVNUM( 2, * ), Q( LDQ, * ),     $                   QSTORE( * ), WORK( * )*     ..**  Purpose*  =======**  DLAED7 computes the updated eigensystem of a diagonal*  matrix after modification by a rank-one symmetric matrix. This*  routine is used only for the eigenproblem which requires all*  eigenvalues and optionally eigenvectors of a dense symmetric matrix*  that has been reduced to tridiagonal form.  DLAED1 handles*  the case in which all eigenvalues and eigenvectors of a symmetric*  tridiagonal matrix are desired.**    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
*     where Z = Q























































































'u, u is a vector of length N with ones in the*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.**     The eigenvectors of the original matrix are stored in Q, and the*     eigenvalues are in D.  The algorithm consists of three stages:**        The first stage consists of deflating the size of the problem*        when there are multiple eigenvalues or if there is a zero in*        the Z vector.  For each such occurence the dimension of the*        secular equation problem is reduced by one.  This stage is*        performed by the routine DLAED8.**        The second stage consists of calculating the updated*        eigenvalues. This is done by finding the roots of the secular*        equation via the routine DLAED4 (as called by DLAED9).*        This routine also calculates the eigenvectors of the current*        problem.**        The final stage consists of computing the updated eigenvectors*        directly using the updated eigenvalues.  The eigenvectors for*        the current problem are multiplied with the eigenvectors from*        the overall problem.**  Arguments*  =========**  ICOMPQ  (input) INTEGER*          = 0:  Compute eigenvalues only.*          = 1:  Compute eigenvectors of original dense symmetric matrix*                also.  On entry, Q contains the orthogonal matrix used*                to reduce the original matrix to tridiagonal form.**  N      (input) INTEGER*         The dimension of the symmetric tridiagonal matrix.  N >= 0.**  QSIZ   (input) INTEGER*         The dimension of the orthogonal matrix used to reduce*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.**  TLVLS  (input) INTEGER*         The total number of merging levels in the overall divide and*         conquer tree.**  CURLVL (input) INTEGER*         The current level in the overall merge routine,*         0 <= CURLVL <= TLVLS.**  CURPBM (input) INTEGER*         The current problem in the current level in the overall*         merge routine (counting from upper left to lower right).**  D      (input/output) DOUBLE PRECISION array, dimension (N)*         On entry, the eigenvalues of the rank-1-perturbed matrix.*         On exit, the eigenvalues of the repaired matrix.**  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)*         On entry, the eigenvectors of the rank-1-perturbed matrix.*         On exit, the eigenvectors of the repaired tridiagonal matrix.**  LDQ    (input) INTEGER*         The leading dimension of the array Q.  LDQ >= max(1,N).**  INDXQ  (output) INTEGER array, dimension (N)*         The permutation which will reintegrate the subproblem just*         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )*         will be in ascending order.**  RHO    (input) DOUBLE PRECISION*         The subdiagonal element used to create the rank-1*         modification.**  CUTPNT (input) INTEGER*         Contains the location of the last eigenvalue in the leading*         sub-matrix.  min(1,N) <= CUTPNT <= N.**  QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)*         Stores eigenvectors of submatrices encountered during*         divide and conquer, packed together. QPTR points to*         beginning of the submatrices.**  QPTR   (input/output) INTEGER array, dimension (N+2)*         List of indices pointing to beginning of submatrices stored*         in QSTORE. The submatrices are numbered starting at the*         bottom left of the divide and conquer tree, from left to*         right and bottom to top.**  PRMPTR (input) INTEGER array, dimension (N lg N)*         Contains a list of pointers which indicate where in PERM a*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
*         indicates the size of the permutation and also the size of
*         the full, non-deflated problem.
*
*  PERM   (input) INTEGER array, dimension (N lg N)
*         Contains the permutations (from deflation and sorting) to be
*         applied to each eigenblock.
*
*  GIVPTR (input) INTEGER array, dimension (N lg N)
*         Contains a list of pointers which indicate where in GIVCOL a
*         level




























































's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)*         indicates the number of Givens rotations.**  GIVCOL (input) INTEGER array, dimension (2, N lg N)*         Each pair of numbers indicates a pair of columns to take place*         in a Givens rotation.**  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)*         Each number indicates the S value to be used in the*         corresponding Givens rotation.**  WORK   (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)**  IWORK  (workspace) INTEGER array, dimension (4*N)**  INFO   (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.*          > 0:  if INFO = 1, an eigenvalue did not converge**  Further Details*  ===============**  Based on contributions by*     Jeff Rutter, Computer Science Division, University of California*     at Berkeley, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )*     ..*     .. Local Scalars ..      INTEGER            COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,     $                   IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR*     ..*     .. External Subroutines ..      EXTERNAL           DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, MIN*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -2      ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN         INFO = -4      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN         INFO = -9      ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN         INFO = -12      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLAED7






































































', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 )     $   RETURN**     The following values are for bookkeeping purposes only.  They are*     integer pointers which indicate the portion of the workspace*     used by a particular array in DLAED8 and DLAED9.*      IF( ICOMPQ.EQ.1 ) THEN         LDQ2 = QSIZ      ELSE         LDQ2 = N      END IF*      IZ = 1      IDLMDA = IZ + N      IW = IDLMDA + N      IQ2 = IW + N      IS = IQ2 + N*LDQ2*      INDX = 1      INDXC = INDX + N      COLTYP = INDXC + N      INDXP = COLTYP + N**     Form the z-vector which consists of the last row of Q_1 and the*     first row of Q_2.*      PTR = 1 + 2**TLVLS      DO 10 I = 1, CURLVL - 1         PTR = PTR + 2**( TLVLS-I )   10 CONTINUE      CURR = PTR + CURPBM      CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,     $             GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),     $             WORK( IZ+N ), INFO )**     When solving the final problem, we no longer need the stored data,*     so we will overwrite the data from this level onto the previously*     used storage space.*      IF( CURLVL.EQ.TLVLS ) THEN         QPTR( CURR ) = 1         PRMPTR( CURR ) = 1         GIVPTR( CURR ) = 1      END IF**     Sort and Deflate eigenvalues.*      CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,     $             WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,     $             WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),     $             GIVCOL( 1, GIVPTR( CURR ) ),     $             GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),     $             IWORK( INDX ), INFO )      PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N      GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )**     Solve Secular Equation.*      IF( K.NE.0 ) THEN         CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),     $                WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )         IF( INFO.NE.0 )     $      GO TO 30         IF( ICOMPQ.EQ.1 ) THEN            CALL DGEMM( 'N', 'N

















































































































































































































', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,     $                  QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )         END IF         QPTR( CURR+1 ) = QPTR( CURR ) + K**2**     Prepare the INDXQ sorting permutation.*         N1 = K         N2 = N - K         CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )      ELSE         QPTR( CURR+1 ) = QPTR( CURR )         DO 20 I = 1, N            INDXQ( I ) = I   20    CONTINUE      END IF*   30 CONTINUE      RETURN**     End of DLAED7*      END      SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,     $                   CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,     $                   GIVCOL, GIVNUM, INDXP, INDX, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,*     Courant Institute, NAG Ltd., and Rice University*     September 30, 1994**     .. Scalar Arguments ..      INTEGER            CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,     $                   QSIZ      DOUBLE PRECISION   RHO*     ..*     .. Array Arguments ..      INTEGER            GIVCOL( 2, * ), INDX( * ), INDXP( * ),     $                   INDXQ( * ), PERM( * )      DOUBLE PRECISION   D( * ), DLAMDA( * ), GIVNUM( 2, * ),     $                   Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )*     ..**  Purpose*  =======**  DLAED8 merges the two sets of eigenvalues together into a single*  sorted set.  Then it tries to deflate the size of the problem.*  There are two ways in which deflation can occur:  when two or more*  eigenvalues are close together or if there is a tiny element in the*  Z vector.  For each such occurrence the order of the related secular*  equation problem is reduced by one.**  Arguments*  =========**  ICOMPQ  (input) INTEGER*          = 0:  Compute eigenvalues only.*          = 1:  Compute eigenvectors of original dense symmetric matrix*                also.  On entry, Q contains the orthogonal matrix used*                to reduce the original matrix to tridiagonal form.**  K      (output) INTEGER*         The number of non-deflated eigenvalues, and the order of the*         related secular equation.**  N      (input) INTEGER*         The dimension of the symmetric tridiagonal matrix.  N >= 0.**  QSIZ   (input) INTEGER*         The dimension of the orthogonal matrix used to reduce*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.**  D      (input/output) DOUBLE PRECISION array, dimension (N)*         On entry, the eigenvalues of the two submatrices to be*         combined.  On exit, the trailing (N-K) updated eigenvalues*         (those which were deflated) sorted into increasing order.**  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N)*         If ICOMPQ = 0, Q is not referenced.  Otherwise,*         on entry, Q contains the eigenvectors of the partially solved*         system which has been previously updated in matrix*         multiplies with other partially solved eigensystems.*         On exit, Q contains the trailing (N-K) updated eigenvectors*         (those which were deflated) in its last N-K columns.**  LDQ    (input) INTEGER*         The leading dimension of the array Q.  LDQ >= max(1,N).**  INDXQ  (input) INTEGER array, dimension (N)*         The permutation which separately sorts the two sub-problems*         in D into ascending order.  Note that elements in the second*         half of this permutation must first have CUTPNT added to*         their values in order to be accurate.**  RHO    (input/output) DOUBLE PRECISION*         On entry, the off-diagonal element associated with the rank-1*         cut which originally split the two submatrices which are now*         being recombined.*         On exit, RHO has been modified to the value required by*         DLAED3.**  CUTPNT (input) INTEGER*         The location of the last eigenvalue in the leading*         sub-matrix.  min(1,N) <= CUTPNT <= N.**  Z      (input) DOUBLE PRECISION array, dimension (N)*         On entry, Z contains the updating vector (the last row of*         the first sub-eigenvector matrix and the first row of the*         second sub-eigenvector matrix).*         On exit, the contents of Z are destroyed by the updating*         process.**  DLAMDA (output) DOUBLE PRECISION array, dimension (N)*         A copy of the first K eigenvalues which will be used by*         DLAED3 to form the secular equation.**  Q2     (output) DOUBLE PRECISION array, dimension (LDQ2,N)*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,*         a copy of the first K eigenvectors which will be used by*         DLAED7 in a matrix multiply (DGEMM) to update the new*         eigenvectors.**  LDQ2   (input) INTEGER*         The leading dimension of the array Q2.  LDQ2 >= max(1,N).**  W      (output) DOUBLE PRECISION array, dimension (N)*         The first k values of the final deflation-altered z-vector and*         will be passed to DLAED3.**  PERM   (output) INTEGER array, dimension (N)*         The permutations (from deflation and sorting) to be applied*         to each eigenblock.**  GIVPTR (output) INTEGER*         The number of Givens rotations which took place in this*         subproblem.**  GIVCOL (output) INTEGER array, dimension (2, N)*         Each pair of numbers indicates a pair of columns to take place*         in a Givens rotation.**  GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)*         Each number indicates the S value to be used in the*         corresponding Givens rotation.**  INDXP  (workspace) INTEGER array, dimension (N)*         The permutation used to place deflated values of D at the end*         of the array.  INDXP(1:K) points to the nondeflated D-values*         and INDXP(K+1:N) points to the deflated eigenvalues.**  INDX   (workspace) INTEGER array, dimension (N)*         The permutation used to sort the contents of D into ascending*         order.**  INFO   (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  Based on contributions by*     Jeff Rutter, Computer Science Division, University of California*     at Berkeley, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   MONE, ZERO, ONE, TWO, EIGHT      PARAMETER          ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,     $                   TWO = 2.0D0, EIGHT = 8.0D0 )*     ..*     .. Local Scalars ..*      INTEGER            I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2      DOUBLE PRECISION   C, EPS, S, T, TAU, TOL*     ..*     .. External Functions ..      INTEGER            IDAMAX      DOUBLE PRECISION   DLAMCH, DLAPY2      EXTERNAL           IDAMAX, DLAMCH, DLAPY2*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, MIN, SQRT*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN         INFO = -1      ELSE IF( N.LT.0 ) THEN         INFO = -3      ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN         INFO = -4      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN         INFO = -7      ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN         INFO = -10      ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN         INFO = -14      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLAED8














































', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 )     $   RETURN*      N1 = CUTPNT      N2 = N - N1      N1P1 = N1 + 1*      IF( RHO.LT.ZERO ) THEN         CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )      END IF**     Normalize z so that norm(z) = 1*      T = ONE / SQRT( TWO )      DO 10 J = 1, N         INDX( J ) = J   10 CONTINUE      CALL DSCAL( N, T, Z, 1 )      RHO = ABS( TWO*RHO )**     Sort the eigenvalues into increasing order*      DO 20 I = CUTPNT + 1, N         INDXQ( I ) = INDXQ( I ) + CUTPNT   20 CONTINUE      DO 30 I = 1, N         DLAMDA( I ) = D( INDXQ( I ) )         W( I ) = Z( INDXQ( I ) )   30 CONTINUE      I = 1      J = CUTPNT + 1      CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )      DO 40 I = 1, N         D( I ) = DLAMDA( INDX( I ) )         Z( I ) = W( INDX( I ) )   40 CONTINUE**     Calculate the allowable deflation tolerence*      IMAX = IDAMAX( N, Z, 1 )      JMAX = IDAMAX( N, D, 1 )      EPS = DLAMCH( 'Epsilon

















' )      TOL = EIGHT*EPS*ABS( D( JMAX ) )**     If the rank-1 modifier is small enough, no more needs to be done*     except to reorganize Q so that its columns correspond with the*     elements in D.*      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN         K = 0         IF( ICOMPQ.EQ.0 ) THEN            DO 50 J = 1, N               PERM( J ) = INDXQ( INDX( J ) )   50       CONTINUE         ELSE            DO 60 J = 1, N               PERM( J ) = INDXQ( INDX( J ) )               CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )   60       CONTINUE            CALL DLACPY( 'A









































































































































', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),     $                   LDQ )         END IF         RETURN      END IF**     If there are multiple eigenvalues then the problem deflates.  Here*     the number of equal eigenvalues are found.  As each equal*     eigenvalue is found, an elementary reflector is computed to rotate*     the corresponding eigensubspace so that the corresponding*     components of Z are zero in this new basis.*      K = 0      GIVPTR = 0      K2 = N + 1      DO 70 J = 1, N         IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN**           Deflate due to small z component.*            K2 = K2 - 1            INDXP( K2 ) = J            IF( J.EQ.N )     $         GO TO 110         ELSE            JLAM = J            GO TO 80         END IF   70 CONTINUE   80 CONTINUE      J = J + 1      IF( J.GT.N )     $   GO TO 100      IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN**        Deflate due to small z component.*         K2 = K2 - 1         INDXP( K2 ) = J      ELSE**        Check if eigenvalues are close enough to allow deflation.*         S = Z( JLAM )         C = Z( J )**        Find sqrt(a**2+b**2) without overflow or*        destructive underflow.*         TAU = DLAPY2( C, S )         T = D( J ) - D( JLAM )         C = C / TAU         S = -S / TAU         IF( ABS( T*C*S ).LE.TOL ) THEN**           Deflation is possible.*            Z( J ) = TAU            Z( JLAM ) = ZERO**           Record the appropriate Givens rotation*            GIVPTR = GIVPTR + 1            GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )            GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )            GIVNUM( 1, GIVPTR ) = C            GIVNUM( 2, GIVPTR ) = S            IF( ICOMPQ.EQ.1 ) THEN               CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,     $                    Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )            END IF            T = D( JLAM )*C*C + D( J )*S*S            D( J ) = D( JLAM )*S*S + D( J )*C*C            D( JLAM ) = T            K2 = K2 - 1            I = 1   90       CONTINUE            IF( K2+I.LE.N ) THEN               IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN                  INDXP( K2+I-1 ) = INDXP( K2+I )                  INDXP( K2+I ) = JLAM                  I = I + 1                  GO TO 90               ELSE                  INDXP( K2+I-1 ) = JLAM               END IF            ELSE               INDXP( K2+I-1 ) = JLAM            END IF            JLAM = J         ELSE            K = K + 1            W( K ) = Z( JLAM )            DLAMDA( K ) = D( JLAM )            INDXP( K ) = JLAM            JLAM = J         END IF      END IF      GO TO 80  100 CONTINUE**     Record the last eigenvalue.*      K = K + 1      W( K ) = Z( JLAM )      DLAMDA( K ) = D( JLAM )      INDXP( K ) = JLAM*  110 CONTINUE**     Sort the eigenvalues and corresponding eigenvectors into DLAMDA*     and Q2 respectively.  The eigenvalues/vectors which were not*     deflated go into the first K slots of DLAMDA and Q2 respectively,*     while those which were deflated go into the last N - K slots.*      IF( ICOMPQ.EQ.0 ) THEN         DO 120 J = 1, N            JP = INDXP( J )            DLAMDA( J ) = D( JP )            PERM( J ) = INDXQ( INDX( JP ) )  120    CONTINUE      ELSE         DO 130 J = 1, N            JP = INDXP( J )            DLAMDA( J ) = D( JP )            PERM( J ) = INDXQ( INDX( JP ) )            CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )  130    CONTINUE      END IF**     The deflated eigenvalues and their corresponding vectors go back*     into the last N - K slots of D and Q respectively.*      IF( K.LT.N ) THEN         IF( ICOMPQ.EQ.0 ) THEN            CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )         ELSE            CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )            CALL DLACPY( 'A


































































































































', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,     $                   Q( 1, K+1 ), LDQ )         END IF      END IF*      RETURN**     End of DLAED8*      END      SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,     $                   S, LDS, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,*     Courant Institute, NAG Ltd., and Rice University*     September 30, 1994**     .. Scalar Arguments ..      INTEGER            INFO, K, KSTART, KSTOP, LDQ, LDS, N      DOUBLE PRECISION   RHO*     ..*     .. Array Arguments ..      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),     $                   W( * )*     ..**  Purpose*  =======**  DLAED9 finds the roots of the secular equation, as defined by the*  values in D, Z, and RHO, between KSTART and KSTOP.  It makes the*  appropriate calls to DLAED4 and then stores the new matrix of*  eigenvectors for use in calculating the next level of Z vectors.**  Arguments*  =========**  K       (input) INTEGER*          The number of terms in the rational function to be solved by*          DLAED4.  K >= 0.**  KSTART  (input) INTEGER*  KSTOP   (input) INTEGER*          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP*          are to be computed.  1 <= KSTART <= KSTOP <= K.**  N       (input) INTEGER*          The number of rows and columns in the Q matrix.*          N >= K (delation may result in N > K).**  D       (output) DOUBLE PRECISION array, dimension (N)*          D(I) contains the updated eigenvalues*          for KSTART <= I <= KSTOP.**  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ,N)**  LDQ     (input) INTEGER*          The leading dimension of the array Q.  LDQ >= max( 1, N ).**  RHO     (input) DOUBLE PRECISION*          The value of the parameter in the rank one update equation.*          RHO >= 0 required.**  DLAMDA  (input) DOUBLE PRECISION array, dimension (K)*          The first K elements of this array contain the old roots*          of the deflated updating problem.  These are the poles*          of the secular equation.**  W       (input) DOUBLE PRECISION array, dimension (K)*          The first K elements of this array contain the components*          of the deflation-adjusted updating vector.**  S       (output) DOUBLE PRECISION array, dimension (LDS, K)*          Will contain the eigenvectors of the repaired matrix which*          will be stored for subsequent Z vector calculation and*          multiplied by the previously accumulated eigenvectors*          to update the system.**  LDS     (input) INTEGER*          The leading dimension of S.  LDS >= max( 1, K ).**  INFO    (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.*          > 0:  if INFO = 1, an eigenvalue did not converge**  Further Details*  ===============**  Based on contributions by*     Jeff Rutter, Computer Science Division, University of California*     at Berkeley, USA**  =====================================================================**     .. Local Scalars ..      INTEGER            I, J      DOUBLE PRECISION   TEMP*     ..*     .. External Functions ..      DOUBLE PRECISION   DLAMC3, DNRM2      EXTERNAL           DLAMC3, DNRM2*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DLAED4, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          MAX, SIGN, SQRT*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( K.LT.0 ) THEN         INFO = -1      ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN         INFO = -2      ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )     $          THEN         INFO = -3      ELSE IF( N.LT.K ) THEN         INFO = -4      ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN         INFO = -7      ELSE IF( LDS.LT.MAX( 1, K ) ) THEN         INFO = -12      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLAED9
































































































































', -INFO )         RETURN      END IF**     Quick return if possible*      IF( K.EQ.0 )     $   RETURN**     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can*     be computed with high relative accuracy (barring over/underflow).*     This is a problem on machines without a guard digit in*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),*     which on any of these machines zeros out the bottommost*     bit of DLAMDA(I) if it is 1; this makes the subsequent*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation*     occurs. On binary machines with a guard digit (almost all*     machines) it does not change DLAMDA(I) at all. On hexadecimal*     and decimal machines with a guard digit, it slightly*     changes the bottommost bits of DLAMDA(I). It does not account*     for hexadecimal or decimal machines without guard digits*     (we know of none). We use a subroutine call to compute*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating*     this code.*      DO 10 I = 1, N         DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )   10 CONTINUE*      DO 20 J = KSTART, KSTOP         CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )**        If the zero finder fails, the computation is terminated.*         IF( INFO.NE.0 )     $      GO TO 120   20 CONTINUE*      IF( K.EQ.1 .OR. K.EQ.2 ) THEN         DO 40 I = 1, K            DO 30 J = 1, K               S( J, I ) = Q( J, I )   30       CONTINUE   40    CONTINUE         GO TO 120      END IF**     Compute updated W.*      CALL DCOPY( K, W, 1, S, 1 )**     Initialize W(I) = Q(I,I)*      CALL DCOPY( K, Q, LDQ+1, W, 1 )      DO 70 J = 1, K         DO 50 I = 1, J - 1            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )   50    CONTINUE         DO 60 I = J + 1, K            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )   60    CONTINUE   70 CONTINUE      DO 80 I = 1, K         W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )   80 CONTINUE**     Compute eigenvectors of the modified rank-1 modification.*      DO 110 J = 1, K         DO 90 I = 1, K            Q( I, J ) = W( I ) / Q( I, J )   90    CONTINUE         TEMP = DNRM2( K, Q( 1, J ), 1 )         DO 100 I = 1, K            S( I, J ) = Q( I, J ) / TEMP  100    CONTINUE  110 CONTINUE*  120 CONTINUE      RETURN**     End of DLAED9*      END      SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,     $                   GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     September 30, 1994**     .. Scalar Arguments ..      INTEGER            CURLVL, CURPBM, INFO, N, TLVLS*     ..*     .. Array Arguments ..      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),     $                   PRMPTR( * ), QPTR( * )      DOUBLE PRECISION   GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )*     ..**  Purpose*  =======**  DLAEDA computes the Z vector corresponding to the merge step in the*  CURLVLth step of the merge process with TLVLS steps for the CURPBMth*  problem.**  Arguments*  =========**  N      (input) INTEGER*         The dimension of the symmetric tridiagonal matrix.  N >= 0.**  TLVLS  (input) INTEGER*         The total number of merging levels in the overall divide and*         conquer tree.**  CURLVL (input) INTEGER*         The current level in the overall merge routine,*         0 <= curlvl <= tlvls.**  CURPBM (input) INTEGER*         The current problem in the current level in the overall*         merge routine (counting from upper left to lower right).**  PRMPTR (input) INTEGER array, dimension (N lg N)*         Contains a list of pointers which indicate where in PERM a*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
*         indicates the size of the permutation and incidentally the
*         size of the full, non-deflated problem.
*
*  PERM   (input) INTEGER array, dimension (N lg N)
*         Contains the permutations (from deflation and sorting) to be
*         applied to each eigenblock.
*
*  GIVPTR (input) INTEGER array, dimension (N lg N)
*         Contains a list of pointers which indicate where in GIVCOL a
*         level































































's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)*         indicates the number of Givens rotations.**  GIVCOL (input) INTEGER array, dimension (2, N lg N)*         Each pair of numbers indicates a pair of columns to take place*         in a Givens rotation.**  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)*         Each number indicates the S value to be used in the*         corresponding Givens rotation.**  Q      (input) DOUBLE PRECISION array, dimension (N**2)*         Contains the square eigenblocks from previous levels, the*         starting positions for blocks are given by QPTR.**  QPTR   (input) INTEGER array, dimension (N+2)*         Contains a list of pointers which indicate where in Q an*         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates*         the size of the block.**  Z      (output) DOUBLE PRECISION array, dimension (N)*         On output this vector contains the updating vector (the last*         row of the first sub-eigenvector matrix and the first row of*         the second sub-eigenvector matrix).**  ZTEMP  (workspace) DOUBLE PRECISION array, dimension (N)**  INFO   (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  Based on contributions by*     Jeff Rutter, Computer Science Division, University of California*     at Berkeley, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO, HALF, ONE      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )*     ..*     .. Local Scalars ..      INTEGER            BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,     $                   PTR, ZPTR1*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DGEMV, DROT, XERBLA*     ..*     .. Intrinsic Functions ..      INTRINSIC          DBLE, INT, SQRT*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( N.LT.0 ) THEN         INFO = -1      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLAEDA















































































', -INFO )         RETURN      END IF**     Quick return if possible*      IF( N.EQ.0 )     $   RETURN**     Determine location of first number in second half.*      MID = N / 2 + 1**     Gather last/first rows of appropriate eigenblocks into center of Z*      PTR = 1**     Determine location of lowest level subproblem in the full storage*     scheme*      CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1**     Determine size of these matrices.  We add HALF to the value of*     the SQRT in case the machine underestimates one of these square*     roots.*      BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )      BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )      DO 10 K = 1, MID - BSIZ1 - 1         Z( K ) = ZERO   10 CONTINUE      CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,     $            Z( MID-BSIZ1 ), 1 )      CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )      DO 20 K = MID + BSIZ2, N         Z( K ) = ZERO   20 CONTINUE**     Loop thru remaining levels 1 -> CURLVL applying the Givens*     rotations and permutation and then multiplying the center matrices*     against the current Z.*      PTR = 2**TLVLS + 1      DO 70 K = 1, CURLVL - 1         CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1         PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )         PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )         ZPTR1 = MID - PSIZ1**       Apply Givens at CURR and CURR+1*         DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1            CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,     $                 Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),     $                 GIVNUM( 2, I ) )   30    CONTINUE         DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1            CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,     $                 Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),     $                 GIVNUM( 2, I ) )   40    CONTINUE         PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )         PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )         DO 50 I = 0, PSIZ1 - 1            ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )   50    CONTINUE         DO 60 I = 0, PSIZ2 - 1            ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )   60    CONTINUE**        Multiply Blocks at CURR and CURR+1**        Determine size of these matrices.  We add HALF to the value of*        the SQRT in case the machine underestimates one of these*        square roots.*         BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )         BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+     $           1 ) ) ) )         IF( BSIZ1.GT.0 ) THEN            CALL DGEMV( 'T





', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),     $                  BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )         END IF         CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),     $               1 )         IF( BSIZ2.GT.0 ) THEN            CALL DGEMV( 'T







































































































































', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),     $                  BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )         END IF         CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,     $               Z( MID+BSIZ2 ), 1 )*         PTR = PTR + 2**( TLVLS-K )   70 CONTINUE*      RETURN**     End of DLAEDA*      END      SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            INFO, N      DOUBLE PRECISION   LAMBDA, TOL*     ..*     .. Array Arguments ..      INTEGER            IN( * )      DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * )*     ..**  Purpose*  =======**  DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n*  tridiagonal matrix and lambda is a scalar, as**     T - lambda*I = PLU,**  where P is a permutation matrix, L is a unit lower tridiagonal matrix*  with at most one non-zero sub-diagonal elements per column and U is*  an upper triangular matrix with at most two non-zero super-diagonal*  elements per column.**  The factorization is obtained by Gaussian elimination with partial*  pivoting and implicit row scaling.**  The parameter LAMBDA is included in the routine so that DLAGTF may*  be used, in conjunction with DLAGTS, to obtain eigenvectors of T by*  inverse iteration.**  Arguments*  =========**  N       (input) INTEGER*          The order of the matrix T.**  A       (input/output) DOUBLE PRECISION array, dimension (N)*          On entry, A must contain the diagonal elements of T.**          On exit, A is overwritten by the n diagonal elements of the*          upper triangular matrix U of the factorization of T.**  LAMBDA  (input) DOUBLE PRECISION*          On entry, the scalar lambda.**  B       (input/output) DOUBLE PRECISION array, dimension (N-1)*          On entry, B must contain the (n-1) super-diagonal elements of*          T.**          On exit, B is overwritten by the (n-1) super-diagonal*          elements of the matrix U of the factorization of T.**  C       (input/output) DOUBLE PRECISION array, dimension (N-1)*          On entry, C must contain the (n-1) sub-diagonal elements of*          T.**          On exit, C is overwritten by the (n-1) sub-diagonal elements*          of the matrix L of the factorization of T.**  TOL     (input) DOUBLE PRECISION*          On entry, a relative tolerance used to indicate whether or*          not the matrix (T - lambda*I) is nearly singular. TOL should*          normally be chose as approximately the largest relative error*          in the elements of T. For example, if the elements of T are*          correct to about 4 significant figures, then TOL should be*          set to about 5*10**(-4). If TOL is supplied as less than eps,*          where eps is the relative machine precision, then the value*          eps is used in place of TOL.**  D       (output) DOUBLE PRECISION array, dimension (N-2)*          On exit, D is overwritten by the (n-2) second super-diagonal*          elements of the matrix U of the factorization of T.**  IN      (output) INTEGER array, dimension (N)*          On exit, IN contains details of the permutation matrix P. If*          an interchange occurred at the kth step of the elimination,*          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)*          returns the smallest positive integer j such that**             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,**          where norm( A(j) ) denotes the sum of the absolute values of*          the jth row of the matrix A. If no such j exists then IN(n)*          is returned as zero. If IN(n) is returned as positive, then a*          diagonal element of U is small, indicating that*          (T - lambda*I) is singular or nearly singular,**  INFO    (output) INTEGER*          = 0   : successful exit*          .lt. 0: if INFO = -k, the kth argument had an illegal value** =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO      PARAMETER          ( ZERO = 0.0D+0 )*     ..*     .. Local Scalars ..      INTEGER            K      DOUBLE PRECISION   EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX*     ..*     .. External Functions ..      DOUBLE PRECISION   DLAMCH      EXTERNAL           DLAMCH*     ..*     .. External Subroutines ..      EXTERNAL           XERBLA*     ..*     .. Executable Statements ..*      INFO = 0      IF( N.LT.0 ) THEN         INFO = -1         CALL XERBLA( 'DLAGTF














', -INFO )         RETURN      END IF*      IF( N.EQ.0 )     $   RETURN*      A( 1 ) = A( 1 ) - LAMBDA      IN( N ) = 0      IF( N.EQ.1 ) THEN         IF( A( 1 ).EQ.ZERO )     $      IN( 1 ) = 1         RETURN      END IF*      EPS = DLAMCH( 'Epsilon












































































































































































































































































' )*      TL = MAX( TOL, EPS )      SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )      DO 10 K = 1, N - 1         A( K+1 ) = A( K+1 ) - LAMBDA         SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )         IF( K.LT.( N-1 ) )     $      SCALE2 = SCALE2 + ABS( B( K+1 ) )         IF( A( K ).EQ.ZERO ) THEN            PIV1 = ZERO         ELSE            PIV1 = ABS( A( K ) ) / SCALE1         END IF         IF( C( K ).EQ.ZERO ) THEN            IN( K ) = 0            PIV2 = ZERO            SCALE1 = SCALE2            IF( K.LT.( N-1 ) )     $         D( K ) = ZERO         ELSE            PIV2 = ABS( C( K ) ) / SCALE2            IF( PIV2.LE.PIV1 ) THEN               IN( K ) = 0               SCALE1 = SCALE2               C( K ) = C( K ) / A( K )               A( K+1 ) = A( K+1 ) - C( K )*B( K )               IF( K.LT.( N-1 ) )     $            D( K ) = ZERO            ELSE               IN( K ) = 1               MULT = A( K ) / C( K )               A( K ) = C( K )               TEMP = A( K+1 )               A( K+1 ) = B( K ) - MULT*TEMP               IF( K.LT.( N-1 ) ) THEN                  D( K ) = B( K+1 )                  B( K+1 ) = -MULT*D( K )               END IF               B( K ) = TEMP               C( K ) = MULT            END IF         END IF         IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )     $      IN( N ) = K   10 CONTINUE      IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )     $   IN( N ) = N*      RETURN**     End of DLAGTF*      END      SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,     $                   POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     December 1, 1999**     .. Scalar Arguments ..      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,     $                   LDGNUM, NL, NR, NRHS, SQRE      DOUBLE PRECISION   C, S*     ..*     .. Array Arguments ..      INTEGER            GIVCOL( LDGCOL, * ), PERM( * )      DOUBLE PRECISION   B( LDB, * ), BX( LDBX, * ), DIFL( * ),     $                   DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),     $                   POLES( LDGNUM, * ), WORK( * ), Z( * )*     ..**  Purpose*  =======**  DLALS0 applies back the multiplying factors of either the left or the*  right singular vector matrix of a diagonal matrix appended by a row*  to the right hand side matrix B in solving the least squares problem*  using the divide-and-conquer SVD approach.**  For the left singular vector matrix, three types of orthogonal*  matrices are involved:**  (1L) Givens rotations: the number of such rotations is GIVPTR; the*       pairs of columns/rows they were applied to are stored in GIVCOL;*       and the C- and S-values of these rotations are stored in GIVNUM.**  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the*       J-th row.**  (3L) The left singular vector matrix of the remaining matrix.**  For the right singular vector matrix, four types of orthogonal*  matrices are involved:**  (1R) The right singular vector matrix of the remaining matrix.**  (2R) If SQRE = 1, one extra Givens rotation to generate the right*       null space.**  (3R) The inverse transformation of (2L).**  (4R) The inverse transformation of (1L).**  Arguments*  =========**  ICOMPQ (input) INTEGER*         Specifies whether singular vectors are to be computed in*         factored form:*         = 0: Left singular vector matrix.*         = 1: Right singular vector matrix.**  NL     (input) INTEGER*         The row dimension of the upper block. NL >= 1.**  NR     (input) INTEGER*         The row dimension of the lower block. NR >= 1.**  SQRE   (input) INTEGER*         = 0: the lower block is an NR-by-NR square matrix.*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.**         The bidiagonal matrix has row dimension N = NL + NR + 1,*         and column dimension M = N + SQRE.**  NRHS   (input) INTEGER*         The number of columns of B and BX. NRHS must be at least 1.**  B      (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )*         On input, B contains the right hand sides of the least*         squares problem in rows 1 through M. On output, B contains*         the solution X in rows 1 through N.**  LDB    (input) INTEGER*         The leading dimension of B. LDB must be at least*         max(1,MAX( M, N ) ).**  BX     (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )**  LDBX   (input) INTEGER*         The leading dimension of BX.**  PERM   (input) INTEGER array, dimension ( N )*         The permutations (from deflation and sorting) applied*         to the two blocks.**  GIVPTR (input) INTEGER*         The number of Givens rotations which took place in this*         subproblem.**  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )*         Each pair of numbers indicates a pair of rows/columns*         involved in a Givens rotation.**  LDGCOL (input) INTEGER*         The leading dimension of GIVCOL, must be at least N.**  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )*         Each number indicates the C or S value used in the*         corresponding Givens rotation.**  LDGNUM (input) INTEGER*         The leading dimension of arrays DIFR, POLES and*         GIVNUM, must be at least K.**  POLES  (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )*         On entry, POLES(1:K, 1) contains the new singular*         values obtained from solving the secular equation, and*         POLES(1:K, 2) is an array containing the poles in the secular*         equation.**  DIFL   (input) DOUBLE PRECISION array, dimension ( K ).*         On entry, DIFL(I) is the distance between I-th updated*         (undeflated) singular value and the I-th (undeflated) old*         singular value.**  DIFR   (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).*         On entry, DIFR(I, 1) contains the distances between I-th*         updated (undeflated) singular value and the I+1-th*         (undeflated) old singular value. And DIFR(I, 2) is the*         normalizing factor for the I-th right singular vector.**  Z      (input) DOUBLE PRECISION array, dimension ( K )*         Contain the components of the deflation-adjusted updating row*         vector.**  K      (input) INTEGER*         Contains the dimension of the non-deflated matrix,*         This is the order of the related secular equation. 1 <= K <=N.**  C      (input) DOUBLE PRECISION*         C contains garbage if SQRE =0 and the C-value of a Givens*         rotation related to the right null space if SQRE = 1.**  S      (input) DOUBLE PRECISION*         S contains garbage if SQRE =0 and the S-value of a Givens*         rotation related to the right null space if SQRE = 1.**  WORK   (workspace) DOUBLE PRECISION array, dimension ( K )**  INFO   (output) INTEGER*          = 0:  successful exit.*          < 0:  if INFO = -i, the i-th argument had an illegal value.**  Further Details*  ===============**  Based on contributions by*     Ming Gu and Ren-Cang Li, Computer Science Division, University of*       California at Berkeley, USA*     Osni Marques, LBNL/NERSC, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO, NEGONE      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )*     ..*     .. Local Scalars ..      INTEGER            I, J, M, N, NLP1      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL,     $                   XERBLA*     ..*     .. External Functions ..      DOUBLE PRECISION   DLAMC3, DNRM2      EXTERNAL           DLAMC3, DNRM2*     ..*     .. Executable Statements ..**     Test the input parameters.*      INFO = 0*      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN         INFO = -1      ELSE IF( NL.LT.1 ) THEN         INFO = -2      ELSE IF( NR.LT.1 ) THEN         INFO = -3      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN         INFO = -4      END IF*      N = NL + NR + 1*      IF( NRHS.LT.1 ) THEN         INFO = -5      ELSE IF( LDB.LT.N ) THEN         INFO = -7      ELSE IF( LDBX.LT.N ) THEN         INFO = -9      ELSE IF( GIVPTR.LT.0 ) THEN         INFO = -11      ELSE IF( LDGCOL.LT.N ) THEN         INFO = -13      ELSE IF( LDGNUM.LT.N ) THEN         INFO = -15      ELSE IF( K.LT.1 ) THEN         INFO = -20      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLALS0







































































', -INFO )         RETURN      END IF*      M = N + SQRE      NLP1 = NL + 1*      IF( ICOMPQ.EQ.0 ) THEN**        Apply back orthogonal transformations from the left.**        Step (1L): apply back the Givens rotations performed.*         DO 10 I = 1, GIVPTR            CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,     $                 B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),     $                 GIVNUM( I, 1 ) )   10    CONTINUE**        Step (2L): permute rows of B.*         CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )         DO 20 I = 2, N            CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )   20    CONTINUE**        Step (3L): apply the inverse of the left singular vector*        matrix to BX.*         IF( K.EQ.1 ) THEN            CALL DCOPY( NRHS, BX, LDBX, B, LDB )            IF( Z( 1 ).LT.ZERO ) THEN               CALL DSCAL( NRHS, NEGONE, B, LDB )            END IF         ELSE            DO 50 J = 1, K               DIFLJ = DIFL( J )               DJ = POLES( J, 1 )               DSIGJ = -POLES( J, 2 )               IF( J.LT.K ) THEN                  DIFRJ = -DIFR( J, 1 )                  DSIGJP = -POLES( J+1, 2 )               END IF               IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )     $              THEN                  WORK( J ) = ZERO               ELSE                  WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /     $                        ( POLES( J, 2 )+DJ )               END IF               DO 30 I = 1, J - 1                  IF( ( Z( I ).EQ.ZERO ) .OR.     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN                     WORK( I ) = ZERO                  ELSE                     WORK( I ) = POLES( I, 2 )*Z( I ) /     $                           ( DLAMC3( POLES( I, 2 ), DSIGJ )-     $                           DIFLJ ) / ( POLES( I, 2 )+DJ )                  END IF   30          CONTINUE               DO 40 I = J + 1, K                  IF( ( Z( I ).EQ.ZERO ) .OR.     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN                     WORK( I ) = ZERO                  ELSE                     WORK( I ) = POLES( I, 2 )*Z( I ) /     $                           ( DLAMC3( POLES( I, 2 ), DSIGJP )+     $                           DIFRJ ) / ( POLES( I, 2 )+DJ )                  END IF   40          CONTINUE               WORK( 1 ) = NEGONE               TEMP = DNRM2( K, WORK, 1 )               CALL DGEMV( 'T

', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,     $                     B( J, 1 ), LDB )               CALL DLASCL( 'G







', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),     $                      LDB, INFO )   50       CONTINUE         END IF**        Move the deflated rows of BX to B also.*         IF( K.LT.MAX( M, N ) )     $      CALL DLACPY( 'A





































', N-K, NRHS, BX( K+1, 1 ), LDBX,     $                   B( K+1, 1 ), LDB )      ELSE**        Apply back the right orthogonal transformations.**        Step (1R): apply back the new right singular vector matrix*        to B.*         IF( K.EQ.1 ) THEN            CALL DCOPY( NRHS, B, LDB, BX, LDBX )         ELSE            DO 80 J = 1, K               DSIGJ = POLES( J, 2 )               IF( Z( J ).EQ.ZERO ) THEN                  WORK( J ) = ZERO               ELSE                  WORK( J ) = -Z( J ) / DIFL( J ) /     $                        ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )               END IF               DO 60 I = 1, J - 1                  IF( Z( J ).EQ.ZERO ) THEN                     WORK( I ) = ZERO                  ELSE                     WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,     $                           2 ) )-DIFR( I, 1 ) ) /     $                           ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )                  END IF   60          CONTINUE               DO 70 I = J + 1, K                  IF( Z( J ).EQ.ZERO ) THEN                     WORK( I ) = ZERO                  ELSE                     WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,     $                           2 ) )-DIFL( I ) ) /     $                           ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )                  END IF   70          CONTINUE               CALL DGEMV( 'T












', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,     $                     BX( J, 1 ), LDBX )   80       CONTINUE         END IF**        Step (2R): if SQRE = 1, apply back the rotation that is*        related to the right null space of the subproblem.*         IF( SQRE.EQ.1 ) THEN            CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )            CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )         END IF         IF( K.LT.MAX( M, N ) )     $      CALL DLACPY( 'A













































































































', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),     $                   LDBX )**        Step (3R): permute rows of B.*         CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )         IF( SQRE.EQ.1 ) THEN            CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )         END IF         DO 90 I = 2, N            CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )   90    CONTINUE**        Step (4R): apply back the Givens rotations performed.*         DO 100 I = GIVPTR, 1, -1            CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,     $                 B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),     $                 -GIVNUM( I, 1 ) )  100    CONTINUE      END IF*      RETURN**     End of DLALS0*      END      SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,     $                   LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,     $                   GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK,     $                   IWORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     June 30, 1999**     .. Scalar Arguments ..      INTEGER            ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,     $                   SMLSIZ*     ..*     .. Array Arguments ..      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),     $                   K( * ), PERM( LDGCOL, * )      DOUBLE PRECISION   B( LDB, * ), BX( LDBX, * ), C( * ),     $                   DIFL( LDU, * ), DIFR( LDU, * ),     $                   GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),     $                   U( LDU, * ), VT( LDU, * ), WORK( * ),     $                   Z( LDU, * )*     ..**  Purpose*  =======**  DLALSA is an itermediate step in solving the least squares problem*  by computing the SVD of the coefficient matrix in compact form (The*  singular vectors are computed as products of simple orthorgonal*  matrices.).**  If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector*  matrix of an upper bidiagonal matrix to the right hand side; and if*  ICOMPQ = 1, DLALSA applies the right singular vector matrix to the*  right hand side. The singular vector matrices were generated in*  compact form by DLALSA.**  Arguments*  =========***  ICOMPQ (input) INTEGER*         Specifies whether the left or the right singular vector*         matrix is involved.*         = 0: Left singular vector matrix*         = 1: Right singular vector matrix**  SMLSIZ (input) INTEGER*         The maximum size of the subproblems at the bottom of the*         computation tree.**  N      (input) INTEGER*         The row and column dimensions of the upper bidiagonal matrix.**  NRHS   (input) INTEGER*         The number of columns of B and BX. NRHS must be at least 1.**  B      (input) DOUBLE PRECISION array, dimension ( LDB, NRHS )*         On input, B contains the right hand sides of the least*         squares problem in rows 1 through M. On output, B contains*         the solution X in rows 1 through N.**  LDB    (input) INTEGER*         The leading dimension of B in the calling subprogram.*         LDB must be at least max(1,MAX( M, N ) ).**  BX     (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )*         On exit, the result of applying the left or right singular*         vector matrix to B.**  LDBX   (input) INTEGER*         The leading dimension of BX.**  U      (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).*         On entry, U contains the left singular vector matrices of all*         subproblems at the bottom level.**  LDU    (input) INTEGER, LDU = > N.*         The leading dimension of arrays U, VT, DIFL, DIFR,*         POLES, GIVNUM, and Z.**  VT     (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).*         On entry, VT' contains the right singular vector matrices of
*         all subproblems at the bottom level.
*
*  K      (input) INTEGER array, dimension ( N ).
*
*  DIFL   (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
*
*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
*         distances between singular values on the I-th level and
*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
*         record the normalizing factors of the right singular vectors
*         matrices of subproblems on I-th level.
*
*  Z      (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
*         On entry, Z(1, I) contains the components of the deflation-
*         adjusted updating row vector for subproblems on the I-th
*         level.
*
*  POLES  (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
*         singular values involved in the secular equations on the I-th
*         level.
*
*  GIVPTR (input) INTEGER array, dimension ( N ).
*         On entry, GIVPTR( I ) records the number of Givens
*         rotations performed on the I-th problem on the computation
*         tree.
*
*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
*         locations of Givens rotations performed on the I-th level on
*         the computation tree.
*
*  LDGCOL (input) INTEGER, LDGCOL = > N.
*         The leading dimension of arrays GIVCOL and PERM.
*
*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).
*         On entry, PERM(*, I) records permutations done on the I-th
*         level of the computation tree.
*
*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
*         values of Givens rotations performed on the I-th level on the
*         computation tree.
*
*  C      (input) DOUBLE PRECISION array, dimension ( N ).
*         On entry, if the I-th subproblem is not square,
*         C( I ) contains the C-value of a Givens rotation related to
*         the right null space of the I-th subproblem.
*
*  S      (input) DOUBLE PRECISION array, dimension ( N ).
*         On entry, if the I-th subproblem is not square,
*         S( I ) contains the S-value of a Givens rotation related to
*         the right null space of the I-th subproblem.
*
*  WORK   (workspace) DOUBLE PRECISION array.
*         The dimension must be at least N.
*
*  IWORK  (workspace) INTEGER array.
*         The dimension must be at least 3 * N
*
*  INFO   (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
*       California at Berkeley, USA
*     Osni Marques, LBNL/NERSC, USA
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
     $                   ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
     $                   NR, NRF, NRP1, SQRE
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLALS0, DLASDT, XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( SMLSIZ.LT.3 ) THEN
         INFO = -2
      ELSE IF( N.LT.SMLSIZ ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.1 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.N ) THEN
         INFO = -6
      ELSE IF( LDBX.LT.N ) THEN
         INFO = -8
      ELSE IF( LDU.LT.N ) THEN
         INFO = -10
      ELSE IF( LDGCOL.LT.N ) THEN
         INFO = -19
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLALSA', -INFO )
         RETURN
      END IF
*
*     Book-keeping and  setting up the computation tree.
*
      INODE = 1
      NDIML = INODE + N
      NDIMR = NDIML + N
*
      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
     $             IWORK( NDIMR ), SMLSIZ )
*
*     The following code applies back the left singular vector factors.
*     For applying back the right singular vector factors, go to 50.
*
      IF( ICOMPQ.EQ.1 ) THEN
         GO TO 50
      END IF
*
*     The nodes on the bottom level of the tree were solved
*     by DLASDQ. The corresponding left and right singular vector
*     matrices are in explicit form. First apply back the left
*     singular vector matrices.
*
      NDB1 = ( ND+1 ) / 2
      DO 10 I = NDB1, ND
*
*        IC : center row of each node
*        NL : number of rows of left  subproblem
*        NR : number of rows of right subproblem
*        NLF: starting row of the left   subproblem
*        NRF: starting row of the right  subproblem
*
         I1 = I - 1
         IC = IWORK( INODE+I1 )
         NL = IWORK( NDIML+I1 )
         NR = IWORK( NDIMR+I1 )
         NLF = IC - NL
         NRF = IC + 1
         CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
         CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
     $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
   10 CONTINUE
*
*     Next copy the rows of B that correspond to unchanged rows
*     in the bidiagonal matrix to BX.
*
      DO 20 I = 1, ND
         IC = IWORK( INODE+I-1 )
         CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
   20 CONTINUE
*
*     Finally go through the left singular vector matrices of all
*     the other subproblems bottom-up on the tree.
*
      J = 2**NLVL
      SQRE = 0
*
      DO 40 LVL = NLVL, 1, -1
         LVL2 = 2*LVL - 1
*
*        find the first node LF and last node LL on
*        the current level LVL
*
         IF( LVL.EQ.1 ) THEN
            LF = 1
            LL = 1
         ELSE
            LF = 2**( LVL-1 )
            LL = 2*LF - 1
         END IF
         DO 30 I = LF, LL
            IM1 = I - 1
            IC = IWORK( INODE+IM1 )
            NL = IWORK( NDIML+IM1 )
            NR = IWORK( NDIMR+IM1 )
            NLF = IC - NL
            NRF = IC + 1
            J = J - 1
            CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
     $                   B( NLF, 1 ), LDB, PERM( NLF, LVL ),
     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
     $                   INFO )
   30    CONTINUE
   40 CONTINUE
      GO TO 90
*
*     ICOMPQ = 1: applying back the right singular vector factors.
*
   50 CONTINUE
*
*     First now go through the right singular vector matrices of all
*     the tree nodes top-down.
*
      J = 0
      DO 70 LVL = 1, NLVL
         LVL2 = 2*LVL - 1
*
*        Find the first node LF and last node LL on
*        the current level LVL.
*
         IF( LVL.EQ.1 ) THEN
            LF = 1
            LL = 1
         ELSE
            LF = 2**( LVL-1 )
            LL = 2*LF - 1
         END IF
         DO 60 I = LL, LF, -1
            IM1 = I - 1
            IC = IWORK( INODE+IM1 )
            NL = IWORK( NDIML+IM1 )
            NR = IWORK( NDIMR+IM1 )
            NLF = IC - NL
            NRF = IC + 1
            IF( I.EQ.LL ) THEN
               SQRE = 0
            ELSE
               SQRE = 1
            END IF
            J = J + 1
            CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
     $                   BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
     $                   INFO )
   60    CONTINUE
   70 CONTINUE
*
*     The nodes on the bottom level of the tree were solved
*     by DLASDQ. The corresponding right singular vector
*     matrices are in explicit form. Apply them back.
*
      NDB1 = ( ND+1 ) / 2
      DO 80 I = NDB1, ND
         I1 = I - 1
         IC = IWORK( INODE+I1 )
         NL = IWORK( NDIML+I1 )
         NR = IWORK( NDIMR+I1 )
         NLP1 = NL + 1
         IF( I.EQ.ND ) THEN
            NRP1 = NR
         ELSE
            NRP1 = NR + 1
         END IF
         NLF = IC - NL
         NRF = IC + 1
         CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
         CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
     $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
   80 CONTINUE
*
   90 CONTINUE
*
      RETURN
*
*     End of DLALSA
*
      END
      SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
     $                   RANK, WORK, IWORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLALSD uses the singular value decomposition of A to solve the least
*  squares problem of finding X to minimize the Euclidean norm of each
*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
*  are N-by-NRHS. The solution X overwrites B.
*
*  The singular values of A smaller than RCOND times the largest
*  singular value are treated as zero in solving the least squares
*  problem; in this case a minimum norm solution is returned.
*  The actual singular values are returned in D in ascending order.
*
*  This code makes very mild assumptions about floating point
*  arithmetic. It will work on machines with a guard digit in
*  add/subtract, or on those binary machines without guard digits
*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
*  It could conceivably fail on hexadecimal or decimal machines
*  without guard digits, but we know of none.
*
*  Arguments
*  =========
*
*  UPLO   (input) CHARACTER*1
*         = 'U': D and E define an upper bidiagonal matrix.
*         = 'L': D and E define a  lower bidiagonal matrix.
*
*  SMLSIZ (input) INTEGER
*         The maximum size of the subproblems at the bottom of the
*         computation tree.
*
*  N      (input) INTEGER
*         The dimension of the  bidiagonal matrix.  N >= 0.
*
*  NRHS   (input) INTEGER
*         The number of columns of B. NRHS must be at least 1.
*
*  D      (input/output) DOUBLE PRECISION array, dimension (N)
*         On entry D contains the main diagonal of the bidiagonal
*         matrix. On exit, if INFO = 0, D contains its singular values.
*
*  E      (input) DOUBLE PRECISION array, dimension (N-1)
*         Contains the super-diagonal entries of the bidiagonal matrix.
*         On exit, E has been destroyed.
*
*  B      (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*         On input, B contains the right hand sides of the least
*         squares problem. On output, B contains the solution X.
*
*  LDB    (input) INTEGER
*         The leading dimension of B in the calling subprogram.
*         LDB must be at least max(1,N).
*
*  RCOND  (input) DOUBLE PRECISION
*         The singular values of A less than or equal to RCOND times
*         the largest singular value are treated as zero in solving
*         the least squares problem. If RCOND is negative,
*         machine precision is used instead.
*         For example, if diag(S)*X=B were the least squares problem,
*         where diag(S) is a diagonal matrix of singular values, the
*         solution would be X(i) = B(i) / S(i) if S(i) is greater than
*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
*         RCOND*max(S).
*
*  RANK   (output) INTEGER
*         The number of singular values of A greater than RCOND times
*         the largest singular value.
*
*  WORK   (workspace) DOUBLE PRECISION array, dimension at least
*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
*         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
*
*  IWORK  (workspace) INTEGER array, dimension at least
*         (3*N*NLVL + 11*N)
*
*  INFO   (output) INTEGER
*         = 0:  successful exit.
*         < 0:  if INFO = -i, the i-th argument had an illegal value.
*         > 0:  The algorithm failed to compute an singular value while
*               working on the submatrix lying in rows and columns
*               INFO/(N+1) through MOD(INFO,N+1).
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
*       California at Berkeley, USA
*     Osni Marques, LBNL/NERSC, USA
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
*     ..
*     .. Local Scalars ..
      INTEGER            BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
     $                   GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
     $                   NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
     $                   SMLSZP, SQRE, ST, ST1, U, VT, Z
      DOUBLE PRECISION   CS, EPS, ORGNRM, R, SN, TOL
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           IDAMAX, DLAMCH, DLANST
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL,
     $                   DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG, SIGN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.1 ) THEN
         INFO = -4
      ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLALSD', -INFO )
         RETURN
      END IF
*
      EPS = DLAMCH( 'Epsilon' )
*
*     Set up the tolerance.
*
      IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
         RCOND = EPS
      END IF
*
      RANK = 0
*
*     Quick return if possible.
*
      IF( N.EQ.0 ) THEN
         RETURN
      ELSE IF( N.EQ.1 ) THEN
         IF( D( 1 ).EQ.ZERO ) THEN
            CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
         ELSE
            RANK = 1
            CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
            D( 1 ) = ABS( D( 1 ) )
         END IF
         RETURN
      END IF
*
*     Rotate the matrix if it is lower bidiagonal.
*
      IF( UPLO.EQ.'L' ) THEN
         DO 10 I = 1, N - 1
            CALL DLARTG( D( I ), E( I ), CS, SN, R )
            D( I ) = R
            E( I ) = SN*D( I+1 )
            D( I+1 ) = CS*D( I+1 )
            IF( NRHS.EQ.1 ) THEN
               CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
            ELSE
               WORK( I*2-1 ) = CS
               WORK( I*2 ) = SN
            END IF
   10    CONTINUE
         IF( NRHS.GT.1 ) THEN
            DO 30 I = 1, NRHS
               DO 20 J = 1, N - 1
                  CS = WORK( J*2-1 )
                  SN = WORK( J*2 )
                  CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
   20          CONTINUE
   30       CONTINUE
         END IF
      END IF
*
*     Scale.
*
      NM1 = N - 1
      ORGNRM = DLANST( 'M', N, D, E )
      IF( ORGNRM.EQ.ZERO ) THEN
         CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
         RETURN
      END IF
*
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
*
*     If N is smaller than the minimum divide size SMLSIZ, then solve
*     the problem with another solver.
*
      IF( N.LE.SMLSIZ ) THEN
         NWORK = 1 + N*N
         CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N )
         CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
     $                LDB, WORK( NWORK ), INFO )
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
         TOL = RCOND*ABS( D( IDAMAX( N, D, 1 ) ) )
         DO 40 I = 1, N
            IF( D( I ).LE.TOL ) THEN
               CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
            ELSE
               CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
     $                      LDB, INFO )
               RANK = RANK + 1
            END IF
   40    CONTINUE
         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
     $               WORK( NWORK ), N )
         CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
*
*        Unscale.
*
         CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
         CALL DLASRT( 'D', N, D, INFO )
         CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
         RETURN
      END IF
*
*     Book-keeping and setting up some constants.
*
      NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
*
      SMLSZP = SMLSIZ + 1
*
      U = 1
      VT = 1 + SMLSIZ*N
      DIFL = VT + SMLSZP*N
      DIFR = DIFL + NLVL*N
      Z = DIFR + NLVL*N*2
      C = Z + NLVL*N
      S = C + N
      POLES = S + N
      GIVNUM = POLES + 2*NLVL*N
      BX = GIVNUM + 2*NLVL*N
      NWORK = BX + N*NRHS
*
      SIZEI = 1 + N
      K = SIZEI + N
      GIVPTR = K + N
      PERM = GIVPTR + N
      GIVCOL = PERM + NLVL*N
      IWK = GIVCOL + NLVL*N*2
*
      ST = 1
      SQRE = 0
      ICMPQ1 = 1
      ICMPQ2 = 0
      NSUB = 0
*
      DO 50 I = 1, N
         IF( ABS( D( I ) ).LT.EPS ) THEN
            D( I ) = SIGN( EPS, D( I ) )
         END IF
   50 CONTINUE
*
      DO 60 I = 1, NM1
         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
            NSUB = NSUB + 1
            IWORK( NSUB ) = ST
*
*           Subproblem found. First determine its size and then
*           apply divide and conquer on it.
*
            IF( I.LT.NM1 ) THEN
*
*              A subproblem with E(I) small for I < NM1.
*
               NSIZE = I - ST + 1
               IWORK( SIZEI+NSUB-1 ) = NSIZE
            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
*              A subproblem with E(NM1) not too small but I = NM1.
*
               NSIZE = N - ST + 1
               IWORK( SIZEI+NSUB-1 ) = NSIZE
            ELSE
*
*              A subproblem with E(NM1) small. This implies an
*              1-by-1 subproblem at D(N), which is not solved
*              explicitly.
*
               NSIZE = I - ST + 1
               IWORK( SIZEI+NSUB-1 ) = NSIZE
               NSUB = NSUB + 1
               IWORK( NSUB ) = N
               IWORK( SIZEI+NSUB-1 ) = 1
               CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
            END IF
            ST1 = ST - 1
            IF( NSIZE.EQ.1 ) THEN
*
*              This is a 1-by-1 subproblem and is not solved
*              explicitly.
*
               CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
            ELSE IF( NSIZE.LE.SMLSIZ ) THEN
*
*              This is a small subproblem and is solved by DLASDQ.
*
               CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
     $                      WORK( VT+ST1 ), N )
               CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
     $                      E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
     $                      N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
               IF( INFO.NE.0 ) THEN
                  RETURN
               END IF
               CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
     $                      WORK( BX+ST1 ), N )
            ELSE
*
*              A large problem. Solve it using divide and conquer.
*
               CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
     $                      E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
     $                      IWORK( K+ST1 ), WORK( DIFL+ST1 ),
     $                      WORK( DIFR+ST1 ), WORK( Z+ST1 ),
     $                      WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
     $                      IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
     $                      WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
     $                      WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
     $                      INFO )
               IF( INFO.NE.0 ) THEN
                  RETURN
               END IF
               BXST = BX + ST1
               CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
     $                      LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
     $                      WORK( VT+ST1 ), IWORK( K+ST1 ),
     $                      WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
     $                      WORK( Z+ST1 ), WORK( POLES+ST1 ),
     $                      IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
     $                      IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
     $                      WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
     $                      IWORK( IWK ), INFO )
               IF( INFO.NE.0 ) THEN
                  RETURN
               END IF
            END IF
            ST = I + 1
         END IF
   60 CONTINUE
*
*     Apply the singular values and treat the tiny ones as zero.
*
      TOL = RCOND*ABS( D( IDAMAX( N, D, 1 ) ) )
*
      DO 70 I = 1, N
*
*        Some of the elements in D can be negative because 1-by-1
*        subproblems were not solved explicitly.
*
         IF( ABS( D( I ) ).LE.TOL ) THEN
            CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
         ELSE
            RANK = RANK + 1
            CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
     $                   WORK( BX+I-1 ), N, INFO )
         END IF
         D( I ) = ABS( D( I ) )
   70 CONTINUE
*
*     Now apply back the right singular vectors.
*
      ICMPQ2 = 1
      DO 80 I = 1, NSUB
         ST = IWORK( I )
         ST1 = ST - 1
         NSIZE = IWORK( SIZEI+I-1 )
         BXST = BX + ST1
         IF( NSIZE.EQ.1 ) THEN
            CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
         ELSE IF( NSIZE.LE.SMLSIZ ) THEN
            CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
     $                  WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
     $                  B( ST, 1 ), LDB )
         ELSE
            CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
     $                   B( ST, 1 ), LDB, WORK( U+ST1 ), N,
     $                   WORK( VT+ST1 ), IWORK( K+ST1 ),
     $                   WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
     $                   WORK( Z+ST1 ), WORK( POLES+ST1 ),
     $                   IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
     $                   IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
     $                   WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
     $                   IWORK( IWK ), INFO )
            IF( INFO.NE.0 ) THEN
               RETURN
            END IF
         END IF
   80 CONTINUE
*
*     Unscale and sort the singular values.
*
      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
      CALL DLASRT( 'D', N, D, INFO )
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
*
      RETURN
*
*     End of DLALSD
*
      END
      SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      INTEGER            DTRD1, DTRD2, N1, N2
*     ..
*     .. Array Arguments ..
      INTEGER            INDEX( * )
      DOUBLE PRECISION   A( * )
*     ..
*
*  Purpose
*  =======
*
*  DLAMRG will create a permutation list which will merge the elements
*  of A (which is composed of two independently sorted sets) into a
*  single set which is sorted in ascending order.
*
*  Arguments
*  =========
*
*  N1     (input) INTEGER
*  N2     (input) INTEGER
*         These arguements contain the respective lengths of the two
*         sorted lists to be merged.
*
*  A      (input) DOUBLE PRECISION array, dimension (N1+N2)
*         The first N1 elements of A contain a list of numbers which
*         are sorted in either ascending or descending order.  Likewise
*         for the final N2 elements.
*
*  DTRD1  (input) INTEGER
*  DTRD2  (input) INTEGER
*         These are the strides to be taken through the array A.
*         Allowable strides are 1 and -1.  They indicate whether a
*         subset of A is sorted in ascending (DTRDx = 1) or descending
*         (DTRDx = -1) order.
*
*  INDEX  (output) INTEGER array, dimension (N1+N2)
*         On exit this array will contain a permutation such that
*         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
*         sorted in ascending order.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IND1, IND2, N1SV, N2SV
*     ..
*     .. Executable Statements ..
*
      N1SV = N1
      N2SV = N2
      IF( DTRD1.GT.0 ) THEN
         IND1 = 1
      ELSE
         IND1 = N1
      END IF
      IF( DTRD2.GT.0 ) THEN
         IND2 = 1 + N1
      ELSE
         IND2 = N1 + N2
      END IF
      I = 1
*     while ( (N1SV > 0) & (N2SV > 0) )
   10 CONTINUE
      IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
         IF( A( IND1 ).LE.A( IND2 ) ) THEN
            INDEX( I ) = IND1
            I = I + 1
            IND1 = IND1 + DTRD1
            N1SV = N1SV - 1
         ELSE
            INDEX( I ) = IND2
            I = I + 1
            IND2 = IND2 + DTRD2
            N2SV = N2SV - 1
         END IF
         GO TO 10
      END IF
*     end while
      IF( N1SV.EQ.0 ) THEN
         DO 20 N1SV = 1, N2SV
            INDEX( I ) = IND2
            I = I + 1
            IND2 = IND2 + DTRD2
   20    CONTINUE
      ELSE
*     N2SV .EQ. 0
         DO 30 N2SV = 1, N1SV
            INDEX( I ) = IND1
            I = I + 1
            IND1 = IND1 + DTRD1
   30    CONTINUE
      END IF
*
      RETURN
*
*     End of DLAMRG
*
      END
      SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            INCV, L, LDC, M, N
      DOUBLE PRECISION   TAU
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLARZ applies a real elementary reflector H to a real M-by-N
*  matrix C, from either the left or the right. H is represented in the
*  form
*
*        H = I - tau * v * v












'**  where tau is a real scalar and v is a real vector.**  If tau = 0, then H is taken to be the unit matrix.***  H is a product of k elementary reflectors as returned by DTZRZF.**  Arguments*  =========**  SIDE    (input) CHARACTER*1*          = 'L
': form  H * C*          = 'R










': form  C * H**  M       (input) INTEGER*          The number of rows of the matrix C.**  N       (input) INTEGER*          The number of columns of the matrix C.**  L       (input) INTEGER*          The number of entries of the vector V containing*          the meaningful part of the Householder vectors.*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R













', N >= L >= 0.**  V       (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))*          The vector v in the representation of H as returned by*          DTZRZF. V is not used if TAU = 0.**  INCV    (input) INTEGER*          The increment between elements of v. INCV <> 0.**  TAU     (input) DOUBLE PRECISION*          The value tau in the representation of H.**  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)*          On entry, the M-by-N matrix C.*          On exit, C is overwritten by the matrix H * C if SIDE = 'L
',*          or C * H if SIDE = 'R





'.**  LDC     (input) INTEGER*          The leading dimension of the array C. LDC >= max(1,M).**  WORK    (workspace) DOUBLE PRECISION array, dimension*                         (N) if SIDE = 'L
'*                      or (M) if SIDE = 'R






















'**  Further Details*  ===============**  Based on contributions by*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )*     ..*     .. External Subroutines ..      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER*     ..*     .. External Functions ..      LOGICAL            LSAME      EXTERNAL           LSAME*     ..*     .. Executable Statements ..*      IF( LSAME( SIDE, 'L









' ) ) THEN**        Form  H * C*         IF( TAU.NE.ZERO ) THEN**           w( 1:n ) = C( 1, 1:n )*            CALL DCOPY( N, C, LDC, WORK, 1 )**           w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )
*
            CALL DGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V,
     $                  INCV, ONE, WORK, 1 )
*
*           C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
*
            CALL DAXPY( N, -TAU, WORK, 1, C, LDC )
*
*           C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
*                               tau * v( 1:l ) * w( 1:n )

















'*            CALL DGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),     $                 LDC )         END IF*      ELSE**        Form  C * H*         IF( TAU.NE.ZERO ) THEN**           w( 1:m ) = C( 1:m, 1 )*            CALL DCOPY( M, C, 1, WORK, 1 )**           w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )*            CALL DGEMV( 'No transpose







', M, L, ONE, C( 1, N-L+1 ), LDC,     $                  V, INCV, ONE, WORK, 1 )**           C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )*            CALL DAXPY( M, -TAU, WORK, 1, C, 1 )**           C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...*                               tau * w( 1:m ) * v( 1:l )'
*
            CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
     $                 LDC )
*
         END IF
*
      END IF
*
      RETURN
*
*     End of DLARZ
*
      END
      SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
     $                   LDV, T, LDT, C, LDC, WORK, LDWORK )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     December 1, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, L, LDC, LDT, LDV, LDWORK, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ),
     $                   WORK( LDWORK, * )
*     ..
*
*  Purpose
*  =======
*
*  DLARZB applies a real block reflector H or its transpose H**T to
*  a real distributed M-by-N  C from the left or the right.
*
*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply H or H
' from the Left*          = 'R': apply H or H' from the Right
*
*  TRANS   (input) CHARACTER*1
*          = 'N': apply H (No transpose)
*          = 'C': apply H




' (Transpose)**  DIRECT  (input) CHARACTER*1*          Indicates how H is formed from a product of elementary*          reflectors*          = 'F
': H = H(1) H(2) . . . H(k) (Forward, not supported yet)*          = 'B




': H = H(k) . . . H(2) H(1) (Backward)**  STOREV  (input) CHARACTER*1*          Indicates how the vectors which define the elementary*          reflectors are stored:*          = 'C
': Columnwise                        (not supported yet)*          = 'R














': Rowwise**  M       (input) INTEGER*          The number of rows of the matrix C.**  N       (input) INTEGER*          The number of columns of the matrix C.**  K       (input) INTEGER*          The order of the matrix T (= the number of elementary*          reflectors whose product defines the block reflector).**  L       (input) INTEGER*          The number of columns of the matrix V containing the*          meaningful part of the Householder reflectors.*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R


', N >= L >= 0.**  V       (input) DOUBLE PRECISION array, dimension (LDV,NV).*          If STOREV = 'C', NV = K; if STOREV = 'R



', NV = L.**  LDV     (input) INTEGER*          The leading dimension of the array V.*          If STOREV = 'C', LDV >= L; if STOREV = 'R










', LDV >= K.**  T       (input) DOUBLE PRECISION array, dimension (LDT,K)*          The triangular K-by-K matrix T in the representation of the*          block reflector.**  LDT     (input) INTEGER*          The leading dimension of the array T. LDT >= K.**  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)*          On entry, the M-by-N matrix C.*          On exit, C is overwritten by H*C or H'*C or C*H or C*H








'.**  LDC     (input) INTEGER*          The leading dimension of the array C. LDC >= max(1,M).**  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)**  LDWORK  (input) INTEGER*          The leading dimension of the array WORK.*          If SIDE = 'L
', LDWORK >= max(1,N);*          if SIDE = 'R


































', LDWORK >= max(1,M).**  Further Details*  ===============**  Based on contributions by*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE      PARAMETER          ( ONE = 1.0D+0 )*     ..*     .. Local Scalars ..      CHARACTER          TRANST      INTEGER            I, INFO, J*     ..*     .. External Functions ..      LOGICAL            LSAME      EXTERNAL           LSAME*     ..*     .. External Subroutines ..      EXTERNAL           DCOPY, DGEMM, DTRMM, XERBLA*     ..*     .. Executable Statements ..**     Quick return if possible*      IF( M.LE.0 .OR. N.LE.0 )     $   RETURN**     Check for currently supported options*      INFO = 0      IF( .NOT.LSAME( DIRECT, 'B

' ) ) THEN         INFO = -3      ELSE IF( .NOT.LSAME( STOREV, 'R



' ) ) THEN         INFO = -4      END IF      IF( INFO.NE.0 ) THEN         CALL XERBLA( 'DLARZB



', -INFO )         RETURN      END IF*      IF( LSAME( TRANS, 'N
' ) ) THEN         TRANST = 'T

'      ELSE         TRANST = 'N


'      END IF*      IF( LSAME( SIDE, 'L

' ) ) THEN**        Form  H * C  or  H' * C
*
*        W( 1:n, 1:k ) = C( 1:k, 1:n )






'*         DO 10 J = 1, K            CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )   10    CONTINUE**        W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...*                        C( m-l+1:m, 1:n )' * V( 1:k, 1:l )


'*         IF( L.GT.0 )     $      CALL DGEMM( 'Transpose', 'Transpose


', N, K, L, ONE,     $                  C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK )**        W( 1:n, 1:k ) = W( 1:n, 1:k ) * T'  or  W( 1:m, 1:k ) * T
*
         CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
     $               LDT, WORK, LDWORK )
*
*        C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )








'*         DO 30 J = 1, N            DO 20 I = 1, K               C( I, J ) = C( I, J ) - WORK( J, I )   20       CONTINUE   30    CONTINUE**        C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...*                            V( 1:k, 1:l )' * W( 1:n, 1:k )


'*         IF( L.GT.0 )     $      CALL DGEMM( 'Transpose', 'Transpose


', L, N, K, -ONE, V, LDV,     $                  WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )*      ELSE IF( LSAME( SIDE, 'R

' ) ) THEN**        Form  C * H  or  C * H'
*
*        W( 1:m, 1:k ) = C( 1:m, 1:k )
*
         DO 40 J = 1, K
            CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   40    CONTINUE
*
*        W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
*                        C( 1:m, n-l+1:n ) * V( 1:k, 1:l )


'*         IF( L.GT.0 )     $      CALL DGEMM( 'No transpose', 'Transpose


', M, K, L, ONE,     $                  C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )**        W( 1:m, 1:k ) = W( 1:m, 1:k ) * T  or  W( 1:m, 1:k ) * T'
*
         CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
     $               LDT, WORK, LDWORK )
*
*        C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
*
         DO 60 J = 1, K
            DO 50 I = 1, M
               C( I, J ) = C( I, J ) - WORK( I, J )
   50       CONTINUE
   60    CONTINUE
*
*        C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
*                            W( 1:m, 1:k ) * V( 1:k, 1:l )
*
         IF( L.GT.0 )
     $      CALL DGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
     $                  WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
*
      END IF
*
      RETURN
*
*     End of DLARZB
*
      END
      SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, STOREV
      INTEGER            K, LDT, LDV, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
*     ..
*
*  Purpose
*  =======
*
*  DLARZT forms the triangular factor T of a real block reflector
*  H of order > n, which is defined as a product of k elementary
*  reflectors.
*
*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*
*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*
*  If STOREV = 'C', the vector which defines the elementary reflector
*  H(i) is stored in the i-th column of the array V, and
*
*     H  =  I - V * T * V

'**  If STOREV = 'R


', the vector which defines the elementary reflector*  H(i) is stored in the i-th row of the array V, and**     H  =  I - V' * T * V
*
*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
*
*  Arguments
*  =========
*
*  DIRECT  (input) CHARACTER*1
*          Specifies the order in which the elementary reflectors are
*          multiplied to form the block reflector:
*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
*  STOREV  (input) CHARACTER*1
*          Specifies how the vectors which define the elementary
*          reflectors are stored (see also Further Details):
*          = 'C': columnwise                        (not supported yet)
*          = 'R': rowwise
*
*  N       (input) INTEGER
*          The order of the block reflector H. N >= 0.
*
*  K       (input) INTEGER
*          The order of the triangular factor T (= the number of
*          elementary reflectors). K >= 1.
*
*  V       (input/output) DOUBLE PRECISION array, dimension
*                               (LDV,K) if STOREV = 'C'
*                               (LDV,N) if STOREV = 'R'
*          The matrix V. See further details.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V.
*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*
*  TAU     (input) DOUBLE PRECISION array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i).
*
*  T       (output) DOUBLE PRECISION array, dimension (LDT,K)
*          The k by k triangular factor T of the block reflector.
*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*          lower triangular. The rest of the array is not used.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= K.
*
*  Further Details
*  ===============
*
*  Based on contributions by
*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
*  The shape of the matrix V and the storage of the vectors which define
*  the H(i) is best illustrated by the following example with n = 5 and
*  k = 3. The elements equal to 1 are not stored; the corresponding
*  array elements are modified but restored on exit. The rest of the
*  array is not used.
*
*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
*
*                                              ______V_____
*         ( v1 v2 v3 )                        /            \
*         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )
*     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )
*         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )
*         ( v1 v2 v3 )
*            .  .  .
*            .  .  .
*            1  .  .
*               1  .
*                  1
*
*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
*
*                                                        ______V_____
*            1                                          /            \
*            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )
*            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )
*            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )
*            .  .  .
*         ( v1 v2 v3 )
*         ( v1 v2 v3 )
*     V = ( v1 v2 v3 )
*         ( v1 v2 v3 )
*         ( v1 v2 v3 )
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, J
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMV, DTRMV, XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Executable Statements ..
*
*     Check for currently supported options
*
      INFO = 0
      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLARZT', -INFO )
         RETURN
      END IF
*
      DO 20 I = K, 1, -1
         IF( TAU( I ).EQ.ZERO ) THEN
*
*           H(i)  =  I
*
            DO 10 J = I, K
               T( J, I ) = ZERO
   10       CONTINUE
         ELSE
*
*           general case
*
            IF( I.LT.K ) THEN
*
*              T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)

'*               CALL DGEMV( 'No transpose





', K-I, N, -TAU( I ),     $                     V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,     $                     T( I+1, I ), 1 )**              T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)*               CALL DTRMV( 'Lower', 'No transpose', 'Non-unit





























































































', K-I,     $                     T( I+1, I+1 ), LDT, T( I+1, I ), 1 )            END IF            T( I, I ) = TAU( I )         END IF   20 CONTINUE      RETURN**     End of DLARZT*      END      SUBROUTINE DLASQ1( N, D, E, WORK, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     October 31, 1999 **     .. Scalar Arguments ..      INTEGER            INFO, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   D( * ), E( * ), WORK( * )*     ..**  Purpose*  =======**  DLASQ1 computes the singular values of a real N-by-N bidiagonal*  matrix with diagonal D and off-diagonal E. The singular values*  are computed to high relative accuracy, in the absence of*  denormalization, underflow and overflow. The algorithm was first*  presented in**  "Accurate singular values and differential qd algorithms" by K. V.*  Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,*  1994,**  and the present implementation is described in "An implementation of*  the dqds Algorithm (Positive Case)", LAPACK Working Note.**  Arguments*  =========**  N     (input) INTEGER*        The number of rows and columns in the matrix. N >= 0.**  D     (input/output) DOUBLE PRECISION array, dimension (N)*        On entry, D contains the diagonal elements of the*        bidiagonal matrix whose SVD is desired. On normal exit,*        D contains the singular values in decreasing order.**  E     (input/output) DOUBLE PRECISION array, dimension (N)*        On entry, elements E(1:N-1) contain the off-diagonal elements*        of the bidiagonal matrix whose SVD is desired.*        On exit, E is overwritten.**  WORK  (workspace) DOUBLE PRECISION array, dimension (4*N)**  INFO  (output) INTEGER*        = 0: successful exit*        < 0: if INFO = -i, the i-th argument had an illegal value*        > 0: the algorithm failed*             = 1, a split was marked by a positive value in E*             = 2, current block of Z not diagonalized after 30*N*                  iterations (in inner while loop)*             = 3, termination criterion of outer while loop not met *                  (program created more than N unreduced blocks)**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ZERO      PARAMETER          ( ZERO = 0.0D0 )*     ..*     .. Local Scalars ..      INTEGER            I, IINFO      DOUBLE PRECISION   EPS, SCALE, SAFMIN, SIGMN, SIGMX*     ..*     .. External Subroutines ..      EXTERNAL           DLAS2, DLASQ2, DLASRT, XERBLA*     ..*     .. External Functions ..      DOUBLE PRECISION   DLAMCH      EXTERNAL           DLAMCH*     ..*     .. Intrinsic Functions ..      INTRINSIC          ABS, MAX, SQRT*     ..*     .. Executable Statements ..*      INFO = 0      IF( N.LT.0 ) THEN         INFO = -2         CALL XERBLA( 'DLASQ1

























', -INFO )         RETURN      ELSE IF( N.EQ.0 ) THEN         RETURN      ELSE IF( N.EQ.1 ) THEN         D( 1 ) = ABS( D( 1 ) )         RETURN      ELSE IF( N.EQ.2 ) THEN         CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )         D( 1 ) = SIGMX         D( 2 ) = SIGMN         RETURN      END IF**     Estimate the largest singular value.*      SIGMX = ZERO      DO 10 I = 1, N - 1         D( I ) = ABS( D( I ) )         SIGMX = MAX( SIGMX, ABS( E( I ) ) )   10 CONTINUE      D( N ) = ABS( D( N ) )**     Early return if SIGMX is zero (matrix is already diagonal).*      IF( SIGMX.EQ.ZERO ) THEN         CALL DLASRT( 'D










', N, D, IINFO )         RETURN      END IF*      DO 20 I = 1, N         SIGMX = MAX( SIGMX, D( I ) )   20 CONTINUE**     Copy D and E into WORK (in the Z format) and scale (squaring the*     input data makes scaling by a power of the radix pointless).*      EPS = DLAMCH( 'Precision
' )      SAFMIN = DLAMCH( 'Safe minimum



' )      SCALE = SQRT( EPS / SAFMIN )      CALL DCOPY( N, D, 1, WORK( 1 ), 2 )      CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 )      CALL DLASCL( 'G


', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,     $             IINFO )*         *     Compute the q's and e












's.*      DO 30 I = 1, 2*N - 1         WORK( I ) = WORK( I )**2   30 CONTINUE      WORK( 2*N ) = ZERO*      CALL DLASQ2( N, WORK, INFO )*      IF( INFO.EQ.0 ) THEN         DO 40 I = 1, N            D( I ) = SQRT( WORK( I ) )   40    CONTINUE         CALL DLASCL( 'G































', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )      END IF*      RETURN**     End of DLASQ1*      END      SUBROUTINE DLASQ2( N, Z, INFO )**  -- LAPACK routine (version 3.0) --*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,*     Courant Institute, Argonne National Lab, and Rice University*     October 31, 1999 **     .. Scalar Arguments ..      INTEGER            INFO, N*     ..*     .. Array Arguments ..      DOUBLE PRECISION   Z( * )*     ..**  Purpose*  =======**  DLASQ2 computes all the eigenvalues of the symmetric positive *  definite tridiagonal matrix associated with the qd array Z to high*  relative accuracy are computed to high relative accuracy, in the*  absence of denormalization, underflow and overflow.**  To see the relation of Z to the tridiagonal matrix, let L be a*  unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and*  let U be an upper bidiagonal matrix with 1's above and diagonal
*  Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
*  symmetric tridiagonal to which it is similar.
*
*  Note : DLASQ2 defines a logical variable, IEEE, which is true
*  on machines which follow ieee-754 floating-point standard in their
*  handling of infinities and NaNs, and false otherwise. This variable
*  is passed to DLASQ3.
*
*  Arguments
*  =========
*
*  N     (input) INTEGER
*        The number of rows and columns in the matrix. N >= 0.
*
*  Z     (workspace) DOUBLE PRECISION array, dimension ( 4*N )
*        On entry Z holds the qd array. On exit, entries 1 to N hold
*        the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
*        trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
*        N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
*        holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
*        shifts that failed.
*
*  INFO  (output) INTEGER
*        = 0: successful exit
*        < 0: if the i-th argument is a scalar and had an illegal
*             value, then INFO = -i, if the i-th argument is an
*             array and the j-entry had an illegal value, then
*             INFO = -(i*100+j)
*        > 0: the algorithm failed
*              = 1, a split was marked by a positive value in E
*              = 2, current block of Z not diagonalized after 30*N
*                   iterations (in inner while loop)
*              = 3, termination criterion of outer while loop not met 
*                   (program created more than N unreduced blocks)
*
*  Further Details
*  ===============
*  Local Variables: I0:N0 defines a current unreduced segment of Z.
*  The shifts are accumulated in SIGMA. Iteration count is in ITER.
*  Ping-pong is controlled by PP (alternates between 0 and 1).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   CBIAS
      PARAMETER          ( CBIAS = 1.50D0 )
      DOUBLE PRECISION   ZERO, HALF, ONE, TWO, FOUR, HUNDRD
      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
     $                     TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            IEEE
      INTEGER            I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, 
     $                   N0, NBIG, NDIV, NFAIL, PP, SPLT
      DOUBLE PRECISION   D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN, 
     $                   QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL, 
     $                   TOL2, TRACE, ZMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASQ3, DLASRT, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*      
*     Test the input arguments.
*     (in case DLASQ2 is not called by DLASQ1)
*
      INFO = 0
      EPS = DLAMCH( 'Precision' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      TOL = EPS*HUNDRD
      TOL2 = TOL**2
*
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DLASQ2', 1 )
         RETURN
      ELSE IF( N.EQ.0 ) THEN
         RETURN
      ELSE IF( N.EQ.1 ) THEN
*
*        1-by-1 case.
*
         IF( Z( 1 ).LT.ZERO ) THEN
            INFO = -201
            CALL XERBLA( 'DLASQ2', 2 )
         END IF
         RETURN
      ELSE IF( N.EQ.2 ) THEN
*
*        2-by-2 case.
*
         IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
            INFO = -2
            CALL XERBLA( 'DLASQ2', 2 )
            RETURN
         ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
            D = Z( 3 )
            Z( 3 ) = Z( 1 )
            Z( 1 ) = D
         END IF
         Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
         IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
            T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) 
            S = Z( 3 )*( Z( 2 ) / T )
            IF( S.LE.T ) THEN
               S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
            ELSE
               S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
            END IF
            T = Z( 1 ) + ( S+Z( 2 ) )
            Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
            Z( 1 ) = T
         END IF
         Z( 2 ) = Z( 3 )
         Z( 6 ) = Z( 2 ) + Z( 1 )
         RETURN
      END IF
*
*     Check for negative data and compute sums of q's and e's.
*
      Z( 2*N ) = ZERO
      EMIN = Z( 2 )
      QMAX = ZERO
      ZMAX = ZERO
      D = ZERO
      E = ZERO
*
      DO 10 K = 1, 2*( N-1 ), 2
         IF( Z( K ).LT.ZERO ) THEN
            INFO = -( 200+K )
            CALL XERBLA( 'DLASQ2', 2 )
            RETURN
         ELSE IF( Z( K+1 ).LT.ZERO ) THEN
            INFO = -( 200+K+1 )
            CALL XERBLA( 'DLASQ2', 2 )
            RETURN
         END IF
         D = D + Z( K )
         E = E + Z( K+1 )
         QMAX = MAX( QMAX, Z( K ) )
         EMIN = MIN( EMIN, Z( K+1 ) )
         ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
   10 CONTINUE
      IF( Z( 2*N-1 ).LT.ZERO ) THEN
         INFO = -( 200+2*N-1 )
         CALL XERBLA( 'DLASQ2', 2 )
         RETURN
      END IF
      D = D + Z( 2*N-1 )
      QMAX = MAX( QMAX, Z( 2*N-1 ) )
      ZMAX = MAX( QMAX, ZMAX )
*
*     Check for diagonality.
*
      IF( E.EQ.ZERO ) THEN
         DO 20 K = 2, N
            Z( K ) = Z( 2*K-1 )
   20    CONTINUE
         CALL DLASRT( 'D', N, Z, IINFO )
         Z( 2*N-1 ) = D
         RETURN
      END IF
*
      TRACE = D + E
*
*     Check for zero data.
*
      IF( TRACE.EQ.ZERO ) THEN
         Z( 2*N-1 ) = ZERO
         RETURN
      END IF
*         
*     Check whether the machine is IEEE conformable.
*         
      IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
     $       ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1      
*         
*     Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
*
      DO 30 K = 2*N, 2, -2
         Z( 2*K ) = ZERO 
         Z( 2*K-1 ) = Z( K ) 
         Z( 2*K-2 ) = ZERO 
         Z( 2*K-3 ) = Z( K-1 ) 
   30 CONTINUE
*
      I0 = 1
      N0 = N
*
*     Reverse the qd-array, if warranted.
*
      IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
         IPN4 = 4*( I0+N0 )
         DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
            TEMP = Z( I4-3 )
            Z( I4-3 ) = Z( IPN4-I4-3 )
            Z( IPN4-I4-3 ) = TEMP
            TEMP = Z( I4-1 )
            Z( I4-1 ) = Z( IPN4-I4-5 )
            Z( IPN4-I4-5 ) = TEMP
   40    CONTINUE
      END IF
*
*     Initial split checking via dqd and Li















's test.*      PP = 0*      DO 80 K = 1, 2*         D = Z( 4*N0+PP-3 )         DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4            IF( Z( I4-1 ).LE.TOL2*D ) THEN               Z( I4-1 ) = -ZERO               D = Z( I4-3 )            ELSE               D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )            END IF   50    CONTINUE**        dqd maps Z to ZZ plus Li's test.
*
         EMIN = Z( 4*I0+PP+1 )
         D = Z( 4*I0+PP-3 )
         DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
            Z( I4-2*PP-2 ) = D + Z( I4-1 )
            IF( Z( I4-1 ).LE.TOL2*D ) THEN
               Z( I4-1 ) = -ZERO
               Z( I4-2*PP-2 ) = D
               Z( I4-2*PP ) = ZERO
               D = Z( I4+1 )
            ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
     $               SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
               TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
               Z( I4-2*PP ) = Z( I4-1 )*TEMP
               D = D*TEMP
            ELSE
               Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
               D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
            END IF
            EMIN = MIN( EMIN, Z( I4-2*PP ) )
   60    CONTINUE 
         Z( 4*N0-PP-2 ) = D
*
*        Now find qmax.
*
         QMAX = Z( 4*I0-PP-2 )
         DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
            QMAX = MAX( QMAX, Z( I4 ) )
   70    CONTINUE
*
*        Prepare for the next iteration on K.
*
         PP = 1 - PP
   80 CONTINUE
*
      ITER = 2
      NFAIL = 0
      NDIV = 2*( N0-I0 )
*
      DO 140 IWHILA = 1, N + 1
         IF( N0.LT.1 ) 
     $      GO TO 150
*
*        While array unfinished do 
*
*        E(N0) holds the value of SIGMA when submatrix in I0:N0
*        splits from the rest of the array, but is negated.
*      
         DESIG = ZERO
         IF( N0.EQ.N ) THEN
            SIGMA = ZERO
         ELSE
            SIGMA = -Z( 4*N0-1 )
         END IF
         IF( SIGMA.LT.ZERO ) THEN
            INFO = 1
            RETURN
         END IF
*
*        Find last unreduced submatrix
's top index I0, find QMAX and*        EMIN. Find Gershgorin-type bound if Q's much greater than E































































































's.*         EMAX = ZERO          IF( N0.GT.I0 ) THEN            EMIN = ABS( Z( 4*N0-5 ) )         ELSE            EMIN = ZERO         END IF         QMIN = Z( 4*N0-3 )         QMAX = QMIN         DO 90 I4 = 4*N0, 8, -4            IF( Z( I4-5 ).LE.ZERO )     $         GO TO 100            IF( QMIN.GE.FOUR*EMAX ) THEN               QMIN = MIN( QMIN, Z( I4-3 ) )               EMAX = MAX( EMAX, Z( I4-5 ) )            END IF            QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )            EMIN = MIN( EMIN, Z( I4-5 ) )   90    CONTINUE         I4 = 4 *  100    CONTINUE         I0 = I4 / 4**        Store EMIN for passing to DLASQ3.*         Z( 4*N0-1 ) = EMIN**        Put -(initial shift) into DMIN.*         DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )**        Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.*         PP = 0 *         NBIG = 30*( N0-I0+1 )         DO 120 IWHILB = 1, NBIG            IF( I0.GT.N0 )      $         GO TO 130**           While submatrix unfinished take a good dqds step.*            CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,     $                   ITER, NDIV, IEEE )*            PP = 1 - PP**           When EMIN is very small check for splits.*            IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN               IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.     $             Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN                  SPLT = I0 - 1                  QMAX = Z( 4*I0-3 )                  EMIN = Z( 4*I0-1 )                  OLDEMN = Z( 4*I0 )                  DO 110 I4 = 4*I0, 4*( N0-3 ), 4                     IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.     $                   Z( I4-1 ).LE.TOL2*SIGMA ) THEN                        Z( I4-1 ) = -SIGMA                        SPLT = I4 / 4                        QMAX = ZERO                        EMIN = Z( I4+3 )                        OLDEMN = Z( I4+4 )                     ELSE                        QMAX = MAX( QMAX, Z( I4+1 ) )                        EMIN = MIN( EMIN, Z( I4-1 ) )                        OLDEMN = MIN( OLDEMN, Z( I4 ) )                     END IF  110             CONTINUE                  Z( 4*N0-1 ) = EMIN                  Z( 4*N0 ) = OLDEMN                  I0 = SPLT + 1               END IF            END IF*  120    CONTINUE*         INFO = 2         RETURN**        end IWHILB*  130    CONTINUE*  140 CONTINUE*      INFO = 3      RETURN**     end IWHILA   *  150 CONTINUE*      *     Move q's to the front.
*      
      DO 160 K = 2, N
         Z( K ) = Z( 4*K-3 )
  160 CONTINUE
*      
*     Sort and compute sum of eigenvalues.
*
      CALL DLASRT( 'D', N, Z, IINFO )
*
      E = ZERO
      DO 170 K = N, 1, -1
         E = E + Z( K )
  170 CONTINUE
*
*     Store trace, sum(eigenvalues) and information on performance.
*
      Z( 2*N+1 ) = TRACE 
      Z( 2*N+2 ) = E
      Z( 2*N+3 ) = DBLE( ITER )
      Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 )
      Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER )
      RETURN
*
*     End of DLASQ2
*
      END
      SUBROUTINE DLASRT( ID, N, D, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          ID
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * )
*     ..
*
*  Purpose
*  =======
*
*  Sort the numbers in D in increasing order (if ID = 'I') or
*  in decreasing order (if ID = 'D' ).
*
*  Use Quick Sort, reverting to Insertion sort on arrays of
*  size <= 20. Dimension of STACK limits N to about 2**32.
*
*  Arguments
*  =========
*
*  ID      (input) CHARACTER*1
*          = 'I': sort D in increasing order;
*          = 'D': sort D in decreasing order.
*
*  N       (input) INTEGER
*          The length of the array D.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the array to be sorted.
*          On exit, D has been sorted into increasing order
*          (D(1) <= ... <= D(N) ) or into decreasing order
*          (D(1) >= ... >= D(N) ), depending on ID.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            SELECT
      PARAMETER          ( SELECT = 20 )
*     ..
*     .. Local Scalars ..
      INTEGER            DIR, ENDD, I, J, START, STKPNT
      DOUBLE PRECISION   D1, D2, D3, DMNMX, TMP
*     ..
*     .. Local Arrays ..
      INTEGER            STACK( 2, 32 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input paramters.
*
      INFO = 0
      DIR = -1
      IF( LSAME( ID, 'D' ) ) THEN
         DIR = 0
      ELSE IF( LSAME( ID, 'I' ) ) THEN
         DIR = 1
      END IF
      IF( DIR.EQ.-1 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASRT', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.LE.1 )
     $   RETURN
*
      STKPNT = 1
      STACK( 1, 1 ) = 1
      STACK( 2, 1 ) = N
   10 CONTINUE
      START = STACK( 1, STKPNT )
      ENDD = STACK( 2, STKPNT )
      STKPNT = STKPNT - 1
      IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
*
*        Do Insertion sort on D( START:ENDD )
*
         IF( DIR.EQ.0 ) THEN
*
*           Sort into decreasing order
*
            DO 30 I = START + 1, ENDD
               DO 20 J = I, START + 1, -1
                  IF( D( J ).GT.D( J-1 ) ) THEN
                     DMNMX = D( J )
                     D( J ) = D( J-1 )
                     D( J-1 ) = DMNMX
                  ELSE
                     GO TO 30
                  END IF
   20          CONTINUE
   30       CONTINUE
*
         ELSE
*
*           Sort into increasing order
*
            DO 50 I = START + 1, ENDD
               DO 40 J = I, START + 1, -1
                  IF( D( J ).LT.D( J-1 ) ) THEN
                     DMNMX = D( J )
                     D( J ) = D( J-1 )
                     D( J-1 ) = DMNMX
                  ELSE
                     GO TO 50
                  END IF
   40          CONTINUE
   50       CONTINUE
*
         END IF
*
      ELSE IF( ENDD-START.GT.SELECT ) THEN
*
*        Partition D( START:ENDD ) and stack parts, largest one first
*
*        Choose partition entry as median of 3
*
         D1 = D( START )
         D2 = D( ENDD )
         I = ( START+ENDD ) / 2
         D3 = D( I )
         IF( D1.LT.D2 ) THEN
            IF( D3.LT.D1 ) THEN
               DMNMX = D1
            ELSE IF( D3.LT.D2 ) THEN
               DMNMX = D3
            ELSE
               DMNMX = D2
            END IF
         ELSE
            IF( D3.LT.D2 ) THEN
               DMNMX = D2
            ELSE IF( D3.LT.D1 ) THEN
               DMNMX = D3
            ELSE
               DMNMX = D1
            END IF
         END IF
*
         IF( DIR.EQ.0 ) THEN
*
*           Sort into decreasing order
*
            I = START - 1
            J = ENDD + 1
   60       CONTINUE
   70       CONTINUE
            J = J - 1
            IF( D( J ).LT.DMNMX )
     $         GO TO 70
   80       CONTINUE
            I = I + 1
            IF( D( I ).GT.DMNMX )
     $         GO TO 80
            IF( I.LT.J ) THEN
               TMP = D( I )
               D( I ) = D( J )
               D( J ) = TMP
               GO TO 60
            END IF
            IF( J-START.GT.ENDD-J-1 ) THEN
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
            ELSE
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
            END IF
         ELSE
*
*           Sort into increasing order
*
            I = START - 1
            J = ENDD + 1
   90       CONTINUE
  100       CONTINUE
            J = J - 1
            IF( D( J ).GT.DMNMX )
     $         GO TO 100
  110       CONTINUE
            I = I + 1
            IF( D( I ).LT.DMNMX )
     $         GO TO 110
            IF( I.LT.J ) THEN
               TMP = D( I )
               D( I ) = D( J )
               D( J ) = TMP
               GO TO 90
            END IF
            IF( J-START.GT.ENDD-J-1 ) THEN
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
            ELSE
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
            END IF
         END IF
      END IF
      IF( STKPNT.GT.0 )
     $   GO TO 10
      RETURN
*
*     End of DLASRT
*
      END
      SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            L, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
*  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z, by means
*  of orthogonal transformations.  Z is an (M+L)-by-(M+L) orthogonal
*  matrix and, R and A1 are M-by-M upper triangular matrices.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  L       (input) INTEGER
*          The number of columns of the matrix A containing the
*          meaningful part of the Householder vectors. N-M >= L >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the leading M-by-N upper trapezoidal part of the
*          array A must contain the matrix to be factorized.
*          On exit, the leading M-by-M upper triangular part of A
*          contains the upper triangular matrix R, and elements N-L+1 to
*          N of the first M rows of A, with the array TAU, represent the
*          orthogonal matrix Z as a product of M elementary reflectors.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  TAU     (output) DOUBLE PRECISION array, dimension (M)
*          The scalar factors of the elementary reflectors.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
*
*  Further Details
*  ===============
*
*  Based on contributions by
*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
*  The factorization is obtained by Householder








's method.  The kth*  transformation matrix, Z( k ), which is used to introduce zeros into*  the ( m - k + 1 )th row of A, is given in the form**     Z( k ) = ( I     0   ),*              ( 0  T( k ) )**  where**     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
*                                                 (   0    )
*                                                 ( z( k ) )
*
*  tau is a scalar and z( k ) is an l element vector. tau and z( k )
*  are chosen to annihilate the elements of the kth row of A2.
*
*  The scalar tau is returned in the kth element of TAU and the vector
*  u( k ) in the kth row of A2, such that the elements of z( k ) are
*  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
*  the upper triangular part of A1.
*
*  Z is given by
*
*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARFG, DLARZ
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
*     Quick return if possible
*
      IF( M.EQ.0 ) THEN
         RETURN
      ELSE IF( M.EQ.N ) THEN
         DO 10 I = 1, N
            TAU( I ) = ZERO
   10    CONTINUE
         RETURN
      END IF
*
      DO 20 I = M, 1, -1
*
*        Generate elementary reflector H(i) to annihilate
*        [ A(i,i) A(i,n-l+1:n) ]
*
         CALL DLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) )
*
*        Apply H(i) to A(1:i-1,i:n) from the right
*
         CALL DLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
     $               TAU( I ), A( 1, I ), LDA, WORK )
*
   20 CONTINUE
*
      RETURN
*
*     End of DLATRZ
*
      END
      SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            INCV, LDC, M, N
      DOUBLE PRECISION   TAU
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  This routine is deprecated and has been replaced by routine DORMRZ.
*
*  DLATZM applies a Householder matrix generated by DTZRQF to a matrix.
*
*  Let P = I - tau*u*u

',   u = ( 1 ),*                              ( v )*  where v is an (m-1) vector if SIDE = 'L
', or a (n-1) vector if*  SIDE = 'R

'.**  If SIDE equals 'L





', let*         C = [ C1 ] 1*             [ C2 ] m-1*               n*  Then C is overwritten by P*C.**  If SIDE equals 'R








', let*         C = [ C1, C2 ] m*                1  n-1*  Then C is overwritten by C*P.**  Arguments*  =========**  SIDE    (input) CHARACTER*1*          = 'L
': form P * C*          = 'R








': form C * P**  M       (input) INTEGER*          The number of rows of the matrix C.**  N       (input) INTEGER*          The number of columns of the matrix C.**  V       (input) DOUBLE PRECISION array, dimension*                  (1 + (M-1)*abs(INCV)) if SIDE = 'L
'*                  (1 + (N-1)*abs(INCV)) if SIDE = 'R










'*          The vector v in the representation of P. V is not used*          if TAU = 0.**  INCV    (input) INTEGER*          The increment between elements of v. INCV <> 0**  TAU     (input) DOUBLE PRECISION*          The value tau in the representation of P.**  C1      (input/output) DOUBLE PRECISION array, dimension*                         (LDC,N) if SIDE = 'L
'*                         (M,1)   if SIDE = 'R
'*          On entry, the n-vector C1 if SIDE = 'L
', or the m-vector C1*          if SIDE = 'R

'.**          On exit, the first row of P*C if SIDE = 'L
', or the first*          column of C*P if SIDE = 'R


'.**  C2      (input/output) DOUBLE PRECISION array, dimension*                         (LDC, N)   if SIDE = 'L
'*                         (LDC, N-1) if SIDE = 'R
'*          On entry, the (m - 1) x n matrix C2 if SIDE = 'L
', or the*          m x (n - 1) matrix C2 if SIDE = 'R

'.**          On exit, rows 2:m of P*C if SIDE = 'L
', or columns 2:m of C*P*          if SIDE = 'R





'.**  LDC     (input) INTEGER*          The leading dimension of the arrays C1 and C2. LDC >= (1,M).**  WORK    (workspace) DOUBLE PRECISION array, dimension*                      (N) if SIDE = 'L
'*                      (M) if SIDE = 'R






















'**  =====================================================================**     .. Parameters ..      DOUBLE PRECISION   ONE, ZERO      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )*     ..*     .. External Subroutines ..      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER*     ..*     .. External Functions ..      LOGICAL            LSAME      EXTERNAL           LSAME*     ..*     .. Intrinsic Functions ..      INTRINSIC          MIN*     ..*     .. Executable Statements ..*      IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) )     $   RETURN*      IF( LSAME( SIDE, 'L

' ) ) THEN**        w := C1 + v' * C2
*
         CALL DCOPY( N, C1, LDC, WORK, 1 )
         CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE,
     $               WORK, 1 )
*
*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w





'*        [ C2 ]    [ C2 ]        [ v ]*         CALL DAXPY( N, -TAU, WORK, 1, C1, LDC )         CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )*      ELSE IF( LSAME( SIDE, 'R




' ) ) THEN**        w := C1 + C2 * v*         CALL DCOPY( M, C1, 1, WORK, 1 )         CALL DGEMV( 'No transpose


', M, N-1, ONE, C2, LDC, V, INCV, ONE,     $               WORK, 1 )**        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
*
         CALL DAXPY( M, -TAU, WORK, 1, C1, 1 )
         CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
      END IF
*
      RETURN
*
*     End of DLATZM
*
      END

Generated by  Doxygen 1.6.0   Back to index