ddisna.f

          SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )
    *
    *  -- LAPACK routine (version 3.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     November 2006
    *
    *     .. 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