![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
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