LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
clarfg.f
Go to the documentation of this file.
00001 *> \brief \b CLARFG
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *> \htmlonly
00009 *> Download CLARFG + dependencies 
00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clarfg.f"> 
00011 *> [TGZ]</a> 
00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clarfg.f"> 
00013 *> [ZIP]</a> 
00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clarfg.f"> 
00015 *> [TXT]</a>
00016 *> \endhtmlonly 
00017 *
00018 *  Definition:
00019 *  ===========
00020 *
00021 *       SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
00022 * 
00023 *       .. Scalar Arguments ..
00024 *       INTEGER            INCX, N
00025 *       COMPLEX            ALPHA, TAU
00026 *       ..
00027 *       .. Array Arguments ..
00028 *       COMPLEX            X( * )
00029 *       ..
00030 *  
00031 *
00032 *> \par Purpose:
00033 *  =============
00034 *>
00035 *> \verbatim
00036 *>
00037 *> CLARFG generates a complex elementary reflector H of order n, such
00038 *> that
00039 *>
00040 *>       H**H * ( alpha ) = ( beta ),   H**H * H = I.
00041 *>              (   x   )   (   0  )
00042 *>
00043 *> where alpha and beta are scalars, with beta real, and x is an
00044 *> (n-1)-element complex vector. H is represented in the form
00045 *>
00046 *>       H = I - tau * ( 1 ) * ( 1 v**H ) ,
00047 *>                     ( v )
00048 *>
00049 *> where tau is a complex scalar and v is a complex (n-1)-element
00050 *> vector. Note that H is not hermitian.
00051 *>
00052 *> If the elements of x are all zero and alpha is real, then tau = 0
00053 *> and H is taken to be the unit matrix.
00054 *>
00055 *> Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
00056 *> \endverbatim
00057 *
00058 *  Arguments:
00059 *  ==========
00060 *
00061 *> \param[in] N
00062 *> \verbatim
00063 *>          N is INTEGER
00064 *>          The order of the elementary reflector.
00065 *> \endverbatim
00066 *>
00067 *> \param[in,out] ALPHA
00068 *> \verbatim
00069 *>          ALPHA is COMPLEX
00070 *>          On entry, the value alpha.
00071 *>          On exit, it is overwritten with the value beta.
00072 *> \endverbatim
00073 *>
00074 *> \param[in,out] X
00075 *> \verbatim
00076 *>          X is COMPLEX array, dimension
00077 *>                         (1+(N-2)*abs(INCX))
00078 *>          On entry, the vector x.
00079 *>          On exit, it is overwritten with the vector v.
00080 *> \endverbatim
00081 *>
00082 *> \param[in] INCX
00083 *> \verbatim
00084 *>          INCX is INTEGER
00085 *>          The increment between elements of X. INCX > 0.
00086 *> \endverbatim
00087 *>
00088 *> \param[out] TAU
00089 *> \verbatim
00090 *>          TAU is COMPLEX
00091 *>          The value tau.
00092 *> \endverbatim
00093 *
00094 *  Authors:
00095 *  ========
00096 *
00097 *> \author Univ. of Tennessee 
00098 *> \author Univ. of California Berkeley 
00099 *> \author Univ. of Colorado Denver 
00100 *> \author NAG Ltd. 
00101 *
00102 *> \date November 2011
00103 *
00104 *> \ingroup complexOTHERauxiliary
00105 *
00106 *  =====================================================================
00107       SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
00108 *
00109 *  -- LAPACK auxiliary routine (version 3.4.0) --
00110 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00111 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00112 *     November 2011
00113 *
00114 *     .. Scalar Arguments ..
00115       INTEGER            INCX, N
00116       COMPLEX            ALPHA, TAU
00117 *     ..
00118 *     .. Array Arguments ..
00119       COMPLEX            X( * )
00120 *     ..
00121 *
00122 *  =====================================================================
00123 *
00124 *     .. Parameters ..
00125       REAL               ONE, ZERO
00126       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
00127 *     ..
00128 *     .. Local Scalars ..
00129       INTEGER            J, KNT
00130       REAL               ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
00131 *     ..
00132 *     .. External Functions ..
00133       REAL               SCNRM2, SLAMCH, SLAPY3
00134       COMPLEX            CLADIV
00135       EXTERNAL           SCNRM2, SLAMCH, SLAPY3, CLADIV
00136 *     ..
00137 *     .. Intrinsic Functions ..
00138       INTRINSIC          ABS, AIMAG, CMPLX, REAL, SIGN
00139 *     ..
00140 *     .. External Subroutines ..
00141       EXTERNAL           CSCAL, CSSCAL
00142 *     ..
00143 *     .. Executable Statements ..
00144 *
00145       IF( N.LE.0 ) THEN
00146          TAU = ZERO
00147          RETURN
00148       END IF
00149 *
00150       XNORM = SCNRM2( N-1, X, INCX )
00151       ALPHR = REAL( ALPHA )
00152       ALPHI = AIMAG( ALPHA )
00153 *
00154       IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
00155 *
00156 *        H  =  I
00157 *
00158          TAU = ZERO
00159       ELSE
00160 *
00161 *        general case
00162 *
00163          BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
00164          SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
00165          RSAFMN = ONE / SAFMIN
00166 *
00167          KNT = 0
00168          IF( ABS( BETA ).LT.SAFMIN ) THEN
00169 *
00170 *           XNORM, BETA may be inaccurate; scale X and recompute them
00171 *
00172    10       CONTINUE
00173             KNT = KNT + 1
00174             CALL CSSCAL( N-1, RSAFMN, X, INCX )
00175             BETA = BETA*RSAFMN
00176             ALPHI = ALPHI*RSAFMN
00177             ALPHR = ALPHR*RSAFMN
00178             IF( ABS( BETA ).LT.SAFMIN )
00179      $         GO TO 10
00180 *
00181 *           New BETA is at most 1, at least SAFMIN
00182 *
00183             XNORM = SCNRM2( N-1, X, INCX )
00184             ALPHA = CMPLX( ALPHR, ALPHI )
00185             BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
00186          END IF
00187          TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
00188          ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA )
00189          CALL CSCAL( N-1, ALPHA, X, INCX )
00190 *
00191 *        If ALPHA is subnormal, it may lose relative accuracy
00192 *
00193          DO 20 J = 1, KNT
00194             BETA = BETA*SAFMIN
00195  20      CONTINUE
00196          ALPHA = BETA
00197       END IF
00198 *
00199       RETURN
00200 *
00201 *     End of CLARFG
00202 *
00203       END
 All Files Functions