1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 3.2) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2006
*
* .. Scalar Arguments ..
INTEGER INCX, N
COMPLEX ALPHA, TAU
* ..
* .. Array Arguments ..
COMPLEX X( * )
* ..
*
* Purpose
* =======
*
* CLARFG 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
* On entry, the value alpha.
* On exit, it is overwritten with the value beta.
*
* X (input/output) COMPLEX 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
* The value tau.
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
REAL SCNRM2, SLAMCH, SLAPY3
COMPLEX CLADIV
EXTERNAL SCNRM2, SLAMCH, SLAPY3, CLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CMPLX, REAL, SIGN
* ..
* .. External Subroutines ..
EXTERNAL CSCAL, CSSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = SCNRM2( N-1, X, INCX )
ALPHR = REAL( ALPHA )
ALPHI = AIMAG( ALPHA )
*
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
RSAFMN = ONE / SAFMIN
*
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
10 CONTINUE
KNT = KNT + 1
CALL CSSCAL( 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 = SCNRM2( N-1, X, INCX )
ALPHA = CMPLX( ALPHR, ALPHI )
BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
END IF
TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA )
CALL CSCAL( N-1, ALPHA, X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of CLARFG
*
END
|
