Return to dlarfg.f CVS log

Up to [local] / rpl / lapack / lapack

Première mise à jour de lapack et blas.

    1: *> \brief \b DLARFG generates an elementary reflector (Householder matrix).
    2: *
    3: *  =========== DOCUMENTATION ===========
    4: *
    5: * Online html documentation available at
    6: *            http://www.netlib.org/lapack/explore-html/
    7: *
    8: *> \htmlonly
    9: *> Download DLARFG + dependencies
   10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfg.f">
   11: *> [TGZ]</a>
   12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfg.f">
   13: *> [ZIP]</a>
   14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfg.f">
   15: *> [TXT]</a>
   16: *> \endhtmlonly
   17: *
   18: *  Definition:
   19: *  ===========
   20: *
   21: *       SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
   22: *
   23: *       .. Scalar Arguments ..
   24: *       INTEGER            INCX, N
   25: *       DOUBLE PRECISION   ALPHA, TAU
   26: *       ..
   27: *       .. Array Arguments ..
   28: *       DOUBLE PRECISION   X( * )
   29: *       ..
   30: *
   31: *
   32: *> \par Purpose:
   33: *  =============
   34: *>
   35: *> \verbatim
   36: *>
   37: *> DLARFG generates a real elementary reflector H of order n, such
   38: *> that
   39: *>
   40: *>       H * ( alpha ) = ( beta ),   H**T * H = I.
   41: *>           (   x   )   (   0  )
   42: *>
   43: *> where alpha and beta are scalars, and x is an (n-1)-element real
   44: *> vector. H is represented in the form
   45: *>
   46: *>       H = I - tau * ( 1 ) * ( 1 v**T ) ,
   47: *>                     ( v )
   48: *>
   49: *> where tau is a real scalar and v is a real (n-1)-element
   50: *> vector.
   51: *>
   52: *> If the elements of x are all zero, then tau = 0 and H is taken to be
   53: *> the unit matrix.
   54: *>
   55: *> Otherwise  1 <= tau <= 2.
   56: *> \endverbatim
   57: *
   58: *  Arguments:
   59: *  ==========
   60: *
   61: *> \param[in] N
   62: *> \verbatim
   63: *>          N is INTEGER
   64: *>          The order of the elementary reflector.
   65: *> \endverbatim
   66: *>
   67: *> \param[in,out] ALPHA
   68: *> \verbatim
   69: *>          ALPHA is DOUBLE PRECISION
   70: *>          On entry, the value alpha.
   71: *>          On exit, it is overwritten with the value beta.
   72: *> \endverbatim
   73: *>
   74: *> \param[in,out] X
   75: *> \verbatim
   76: *>          X is DOUBLE PRECISION array, dimension
   77: *>                         (1+(N-2)*abs(INCX))
   78: *>          On entry, the vector x.
   79: *>          On exit, it is overwritten with the vector v.
   80: *> \endverbatim
   81: *>
   82: *> \param[in] INCX
   83: *> \verbatim
   84: *>          INCX is INTEGER
   85: *>          The increment between elements of X. INCX > 0.
   86: *> \endverbatim
   87: *>
   88: *> \param[out] TAU
   89: *> \verbatim
   90: *>          TAU is DOUBLE PRECISION
   91: *>          The value tau.
   92: *> \endverbatim
   93: *
   94: *  Authors:
   95: *  ========
   96: *
   97: *> \author Univ. of Tennessee
   98: *> \author Univ. of California Berkeley
   99: *> \author Univ. of Colorado Denver
  100: *> \author NAG Ltd.
  101: *
  102: *> \ingroup doubleOTHERauxiliary
  103: *
  104: *  =====================================================================
  105:       SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
  106: *
  107: *  -- LAPACK auxiliary routine --
  108: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  109: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  110: *
  111: *     .. Scalar Arguments ..
  112:       INTEGER            INCX, N
  113:       DOUBLE PRECISION   ALPHA, TAU
  114: *     ..
  115: *     .. Array Arguments ..
  116:       DOUBLE PRECISION   X( * )
  117: *     ..
  118: *
  119: *  =====================================================================
  120: *
  121: *     .. Parameters ..
  122:       DOUBLE PRECISION   ONE, ZERO
  123:       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  124: *     ..
  125: *     .. Local Scalars ..
  126:       INTEGER            J, KNT
  127:       DOUBLE PRECISION   BETA, RSAFMN, SAFMIN, XNORM
  128: *     ..
  129: *     .. External Functions ..
  130:       DOUBLE PRECISION   DLAMCH, DLAPY2, DNRM2
  131:       EXTERNAL           DLAMCH, DLAPY2, DNRM2
  132: *     ..
  133: *     .. Intrinsic Functions ..
  134:       INTRINSIC          ABS, SIGN
  135: *     ..
  136: *     .. External Subroutines ..
  137:       EXTERNAL           DSCAL
  138: *     ..
  139: *     .. Executable Statements ..
  140: *
  141:       IF( N.LE.1 ) THEN
  142:          TAU = ZERO
  143:          RETURN
  144:       END IF
  145: *
  146:       XNORM = DNRM2( N-1, X, INCX )
  147: *
  148:       IF( XNORM.EQ.ZERO ) THEN
  149: *
  150: *        H  =  I
  151: *
  152:          TAU = ZERO
  153:       ELSE
  154: *
  155: *        general case
  156: *
  157:          BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
  158:          SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
  159:          KNT = 0
  160:          IF( ABS( BETA ).LT.SAFMIN ) THEN
  161: *
  162: *           XNORM, BETA may be inaccurate; scale X and recompute them
  163: *
  164:             RSAFMN = ONE / SAFMIN
  165:    10       CONTINUE
  166:             KNT = KNT + 1
  167:             CALL DSCAL( N-1, RSAFMN, X, INCX )
  168:             BETA = BETA*RSAFMN
  169:             ALPHA = ALPHA*RSAFMN
  170:             IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) )
  171:      $         GO TO 10
  172: *
  173: *           New BETA is at most 1, at least SAFMIN
  174: *
  175:             XNORM = DNRM2( N-1, X, INCX )
  176:             BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
  177:          END IF
  178:          TAU = ( BETA-ALPHA ) / BETA
  179:          CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
  180: *
  181: *        If ALPHA is subnormal, it may lose relative accuracy
  182: *
  183:          DO 20 J = 1, KNT
  184:             BETA = BETA*SAFMIN
  185:  20      CONTINUE
  186:          ALPHA = BETA
  187:       END IF
  188: *
  189:       RETURN
  190: *
  191: *     End of DLARFG
  192: *
  193:       END