Return to zlarfg.f CVS log

Up to [local] / rpl / lapack / lapack

Mise à jour de lapack.

    1: *> \brief \b ZLARFG 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 ZLARFG + dependencies
   10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfg.f">
   11: *> [TGZ]</a>
   12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfg.f">
   13: *> [ZIP]</a>
   14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfg.f">
   15: *> [TXT]</a>
   16: *> \endhtmlonly
   17: *
   18: *  Definition:
   19: *  ===========
   20: *
   21: *       SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
   22: *
   23: *       .. Scalar Arguments ..
   24: *       INTEGER            INCX, N
   25: *       COMPLEX*16         ALPHA, TAU
   26: *       ..
   27: *       .. Array Arguments ..
   28: *       COMPLEX*16         X( * )
   29: *       ..
   30: *
   31: *
   32: *> \par Purpose:
   33: *  =============
   34: *>
   35: *> \verbatim
   36: *>
   37: *> ZLARFG generates a complex elementary reflector H of order n, such
   38: *> that
   39: *>
   40: *>       H**H * ( alpha ) = ( beta ),   H**H * H = I.
   41: *>              (   x   )   (   0  )
   42: *>
   43: *> where alpha and beta are scalars, with beta real, and x is an
   44: *> (n-1)-element complex vector. H is represented in the form
   45: *>
   46: *>       H = I - tau * ( 1 ) * ( 1 v**H ) ,
   47: *>                     ( v )
   48: *>
   49: *> where tau is a complex scalar and v is a complex (n-1)-element
   50: *> vector. Note that H is not hermitian.
   51: *>
   52: *> If the elements of x are all zero and alpha is real, then tau = 0
   53: *> and H is taken to be the unit matrix.
   54: *>
   55: *> Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
   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 COMPLEX*16
   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 COMPLEX*16 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 COMPLEX*16
   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: *> \date December 2016
  103: *
  104: *> \ingroup complex16OTHERauxiliary
  105: *
  106: *  =====================================================================
  107:       SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
  108: *
  109: *  -- LAPACK auxiliary routine (version 3.7.0) --
  110: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  111: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  112: *     December 2016
  113: *
  114: *     .. Scalar Arguments ..
  115:       INTEGER            INCX, N
  116:       COMPLEX*16         ALPHA, TAU
  117: *     ..
  118: *     .. Array Arguments ..
  119:       COMPLEX*16         X( * )
  120: *     ..
  121: *
  122: *  =====================================================================
  123: *
  124: *     .. Parameters ..
  125:       DOUBLE PRECISION   ONE, ZERO
  126:       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  127: *     ..
  128: *     .. Local Scalars ..
  129:       INTEGER            J, KNT
  130:       DOUBLE PRECISION   ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
  131: *     ..
  132: *     .. External Functions ..
  133:       DOUBLE PRECISION   DLAMCH, DLAPY3, DZNRM2
  134:       COMPLEX*16         ZLADIV
  135:       EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
  136: *     ..
  137: *     .. Intrinsic Functions ..
  138:       INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, SIGN
  139: *     ..
  140: *     .. External Subroutines ..
  141:       EXTERNAL           ZDSCAL, ZSCAL
  142: *     ..
  143: *     .. Executable Statements ..
  144: *
  145:       IF( N.LE.0 ) THEN
  146:          TAU = ZERO
  147:          RETURN
  148:       END IF
  149: *
  150:       XNORM = DZNRM2( N-1, X, INCX )
  151:       ALPHR = DBLE( ALPHA )
  152:       ALPHI = DIMAG( ALPHA )
  153: *
  154:       IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
  155: *
  156: *        H  =  I
  157: *
  158:          TAU = ZERO
  159:       ELSE
  160: *
  161: *        general case
  162: *
  163:          BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
  164:          SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
  165:          RSAFMN = ONE / SAFMIN
  166: *
  167:          KNT = 0
  168:          IF( ABS( BETA ).LT.SAFMIN ) THEN
  169: *
  170: *           XNORM, BETA may be inaccurate; scale X and recompute them
  171: *
  172:    10       CONTINUE
  173:             KNT = KNT + 1
  174:             CALL ZDSCAL( N-1, RSAFMN, X, INCX )
  175:             BETA = BETA*RSAFMN
  176:             ALPHI = ALPHI*RSAFMN
  177:             ALPHR = ALPHR*RSAFMN
  178:             IF( ABS( BETA ).LT.SAFMIN )
  179:      $         GO TO 10
  180: *
  181: *           New BETA is at most 1, at least SAFMIN
  182: *
  183:             XNORM = DZNRM2( N-1, X, INCX )
  184:             ALPHA = DCMPLX( ALPHR, ALPHI )
  185:             BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
  186:          END IF
  187:          TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
  188:          ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
  189:          CALL ZSCAL( N-1, ALPHA, X, INCX )
  190: *
  191: *        If ALPHA is subnormal, it may lose relative accuracy
  192: *
  193:          DO 20 J = 1, KNT
  194:             BETA = BETA*SAFMIN
  195:  20      CONTINUE
  196:          ALPHA = BETA
  197:       END IF
  198: *
  199:       RETURN
  200: *
  201: *     End of ZLARFG
  202: *
  203:       END