119 parameter( two = 2.0e+0, one = 1.0e+0, zero = 0.0e+0 )
123 REAL ALPHI, ALPHR, BETA, BIGNUM, EPS, SMLNUM, XNORM
127 REAL SCNRM2, SLAMCH, SLAPY3, SLAPY2
129 EXTERNAL scnrm2, slamch, slapy3, slapy2,
133 INTRINSIC abs, aimag, cmplx, real, sign
145 eps = slamch(
'Precision' )
146 xnorm = scnrm2( n-1, x, incx )
147 alphr = real( alpha )
148 alphi = aimag( alpha )
150 IF( xnorm.LE.eps*abs(alpha) .AND. alphi.EQ.zero )
THEN
154 IF( alphr.GE.zero )
THEN
164 x( 1 + (j-1)*incx ) = zero
172 beta = sign( slapy3( alphr, alphi, xnorm ), alphr )
173 smlnum = slamch(
'S' ) / slamch(
'E' )
174 bignum = one / smlnum
177 IF( abs( beta ).LT.smlnum )
THEN
183 CALL csscal( n-1, bignum, x, incx )
187 IF( (abs( beta ).LT.smlnum) .AND. (knt .LT. 20) )
192 xnorm = scnrm2( n-1, x, incx )
193 alpha = cmplx( alphr, alphi )
194 beta = sign( slapy3( alphr, alphi, xnorm ), alphr )
198 IF( beta.LT.zero )
THEN
202 alphr = alphi * (alphi/real( alpha ))
203 alphr = alphr + xnorm * (xnorm/real( alpha ))
204 tau = cmplx( alphr/beta, -alphi/beta )
205 alpha = cmplx( -alphr, alphi )
207 alpha = cladiv( cmplx( one ), alpha )
209 IF ( abs(tau).LE.smlnum )
THEN
218 alphr = real( savealpha )
219 alphi = aimag( savealpha )
220 IF( alphi.EQ.zero )
THEN
221 IF( alphr.GE.zero )
THEN
226 x( 1 + (j-1)*incx ) = zero
228 beta = real( -savealpha )
231 xnorm = slapy2( alphr, alphi )
232 tau = cmplx( one - alphr / xnorm, -alphi / xnorm )
234 x( 1 + (j-1)*incx ) = zero
243 CALL cscal( n-1, alpha, x, incx )
subroutine clarfgp(n, alpha, x, incx, tau)
CLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.