```001:       SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
002: *
003: *  -- LAPACK auxiliary routine (version 3.2) --
004: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
005: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       INTEGER            INCX, N
010:       DOUBLE PRECISION   ALPHA, TAU
011: *     ..
012: *     .. Array Arguments ..
013:       DOUBLE PRECISION   X( * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  DLARFG generates a real elementary reflector H of order n, such
020: *  that
021: *
022: *        H * ( alpha ) = ( beta ),   H' * H = I.
023: *            (   x   )   (   0  )
024: *
025: *  where alpha and beta are scalars, and x is an (n-1)-element real
026: *  vector. H is represented in the form
027: *
028: *        H = I - tau * ( 1 ) * ( 1 v' ) ,
029: *                      ( v )
030: *
031: *  where tau is a real scalar and v is a real (n-1)-element
032: *  vector.
033: *
034: *  If the elements of x are all zero, then tau = 0 and H is taken to be
035: *  the unit matrix.
036: *
037: *  Otherwise  1 <= tau <= 2.
038: *
039: *  Arguments
040: *  =========
041: *
042: *  N       (input) INTEGER
043: *          The order of the elementary reflector.
044: *
045: *  ALPHA   (input/output) DOUBLE PRECISION
046: *          On entry, the value alpha.
047: *          On exit, it is overwritten with the value beta.
048: *
049: *  X       (input/output) DOUBLE PRECISION array, dimension
050: *                         (1+(N-2)*abs(INCX))
051: *          On entry, the vector x.
052: *          On exit, it is overwritten with the vector v.
053: *
054: *  INCX    (input) INTEGER
055: *          The increment between elements of X. INCX > 0.
056: *
057: *  TAU     (output) DOUBLE PRECISION
058: *          The value tau.
059: *
060: *  =====================================================================
061: *
062: *     .. Parameters ..
063:       DOUBLE PRECISION   ONE, ZERO
064:       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
065: *     ..
066: *     .. Local Scalars ..
067:       INTEGER            J, KNT
068:       DOUBLE PRECISION   BETA, RSAFMN, SAFMIN, XNORM
069: *     ..
070: *     .. External Functions ..
071:       DOUBLE PRECISION   DLAMCH, DLAPY2, DNRM2
072:       EXTERNAL           DLAMCH, DLAPY2, DNRM2
073: *     ..
074: *     .. Intrinsic Functions ..
075:       INTRINSIC          ABS, SIGN
076: *     ..
077: *     .. External Subroutines ..
078:       EXTERNAL           DSCAL
079: *     ..
080: *     .. Executable Statements ..
081: *
082:       IF( N.LE.1 ) THEN
083:          TAU = ZERO
084:          RETURN
085:       END IF
086: *
087:       XNORM = DNRM2( N-1, X, INCX )
088: *
089:       IF( XNORM.EQ.ZERO ) THEN
090: *
091: *        H  =  I
092: *
093:          TAU = ZERO
094:       ELSE
095: *
096: *        general case
097: *
098:          BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
099:          SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
100:          KNT = 0
101:          IF( ABS( BETA ).LT.SAFMIN ) THEN
102: *
103: *           XNORM, BETA may be inaccurate; scale X and recompute them
104: *
105:             RSAFMN = ONE / SAFMIN
106:    10       CONTINUE
107:             KNT = KNT + 1
108:             CALL DSCAL( N-1, RSAFMN, X, INCX )
109:             BETA = BETA*RSAFMN
110:             ALPHA = ALPHA*RSAFMN
111:             IF( ABS( BETA ).LT.SAFMIN )
112:      \$         GO TO 10
113: *
114: *           New BETA is at most 1, at least SAFMIN
115: *
116:             XNORM = DNRM2( N-1, X, INCX )
117:             BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
118:          END IF
119:          TAU = ( BETA-ALPHA ) / BETA
120:          CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
121: *
122: *        If ALPHA is subnormal, it may lose relative accuracy
123: *
124:          DO 20 J = 1, KNT
125:             BETA = BETA*SAFMIN
126:  20      CONTINUE
127:          ALPHA = BETA
128:       END IF
129: *
130:       RETURN
131: *
132: *     End of DLARFG
133: *
134:       END
135: ```