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