zlarfg.f

          SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
    *
    *  -- LAPACK auxiliary routine (version 3.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     November 2006
    *
    *     .. Scalar Arguments ..
          INTEGER            INCX, N
          COMPLEX*16         ALPHA, TAU
    *     ..
    *     .. Array Arguments ..
          COMPLEX*16         X( * )
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  ZLARFG generates a complex elementary reflector H of order n, such
    *  that
    *
    *        H' * ( alpha ) = ( beta ),   H' * H = I.
    *             (   x   )   (   0  )
    *
    *  where alpha and beta are scalars, with beta real, and x is an
    *  (n-1)-element complex vector. H is represented in the form
    *
    *        H = I - tau * ( 1 ) * ( 1 v' ) ,
    *                      ( v )
    *
    *  where tau is a complex scalar and v is a complex (n-1)-element
    *  vector. Note that H is not hermitian.
    *
    *  If the elements of x are all zero and alpha is real, then tau = 0
    *  and H is taken to be the unit matrix.
    *
    *  Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
    *
    *  Arguments
    *  =========
    *
    *  N       (input) INTEGER
    *          The order of the elementary reflector.
    *
    *  ALPHA   (input/output) COMPLEX*16
    *          On entry, the value alpha.
    *          On exit, it is overwritten with the value beta.
    *
    *  X       (input/output) COMPLEX*16 array, dimension
    *                         (1+(N-2)*abs(INCX))
    *          On entry, the vector x.
    *          On exit, it is overwritten with the vector v.
    *
    *  INCX    (input) INTEGER
    *          The increment between elements of X. INCX > 0.
    *
    *  TAU     (output) COMPLEX*16
    *          The value tau.
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          DOUBLE PRECISION   ONE, ZERO
          PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
    *     ..
    *     .. Local Scalars ..
          INTEGER            J, KNT
          DOUBLE PRECISION   ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
    *     ..
    *     .. External Functions ..
          DOUBLE PRECISION   DLAMCH, DLAPY3, DZNRM2
          COMPLEX*16         ZLADIV
          EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, SIGN
    *     ..
    *     .. External Subroutines ..
          EXTERNAL           ZDSCAL, ZSCAL
    *     ..
    *     .. Executable Statements ..
    *
          IF( N.LE.0 ) THEN
             TAU = ZERO
             RETURN
          END IF
    *
          XNORM = DZNRM2( N-1, X, INCX )
          ALPHR = DBLE( ALPHA )
          ALPHI = DIMAG( ALPHA )
    *
          IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
    *
    *        H  =  I
    *
             TAU = ZERO
          ELSE
    *
    *        general case
    *
             BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
             SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
             RSAFMN = ONE / SAFMIN
    *
             IF( ABS( BETA ).LT.SAFMIN ) THEN
    *
    *           XNORM, BETA may be inaccurate; scale X and recompute them
    *
                KNT = 0
       10       CONTINUE
                KNT = KNT + 1
                CALL ZDSCAL( N-1, RSAFMN, X, INCX )
                BETA = BETA*RSAFMN
                ALPHI = ALPHI*RSAFMN
                ALPHR = ALPHR*RSAFMN
                IF( ABS( BETA ).LT.SAFMIN )
         $         GO TO 10
    *
    *           New BETA is at most 1, at least SAFMIN
    *
                XNORM = DZNRM2( N-1, X, INCX )
                ALPHA = DCMPLX( ALPHR, ALPHI )
                BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
                TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
                ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
                CALL ZSCAL( N-1, ALPHA, X, INCX )
    *
    *           If ALPHA is subnormal, it may lose relative accuracy
    *
                ALPHA = BETA
                DO 20 J = 1, KNT
                   ALPHA = ALPHA*SAFMIN
       20       CONTINUE
             ELSE
                TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
                ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
                CALL ZSCAL( N-1, ALPHA, X, INCX )
                ALPHA = BETA
             END IF
          END IF
    *
          RETURN
    *
    *     End of ZLARFG
    *
          END