Télécharger dlarfg.eso

Retour à la liste

Numérotation des lignes :

  1. C DLARFG SOURCE BP208322 15/10/13 21:15:34 8670
  2. *> \brief \b DLARFG generates an elementary reflector (Householder matrix).
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. *> \htmlonly
  10. *> Download DLARFG + dependencies
  11. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfg.f">
  12. *> [TGZ]</a>
  13. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfg.f">
  14. *> [ZIP]</a>
  15. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfg.f">
  16. *> [TXT]</a>
  17. *> \endhtmlonly
  18. *
  19. * Definition:
  20. * ===========
  21. *
  22. * SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
  23. *
  24. * .. Scalar Arguments ..
  25. * INTEGER INCX, N
  26. * REAL*8 ALPHA, TAU
  27. * ..
  28. * .. Array Arguments ..
  29. * REAL*8 X( * )
  30. * ..
  31. *
  32. *
  33. *> \par Purpose:
  34. * =============
  35. *>
  36. *> \verbatim
  37. *>
  38. *> DLARFG generates a real elementary reflector H of order n, such
  39. *> that
  40. *>
  41. *> H * ( alpha ) = ( beta ), H**T * H = I.
  42. *> ( x ) ( 0 )
  43. *>
  44. *> where alpha and beta are scalars, and x is an (n-1)-element real
  45. *> vector. H is represented in the form
  46. *>
  47. *> H = I - tau * ( 1 ) * ( 1 v**T ) ,
  48. *> ( v )
  49. *>
  50. *> where tau is a real scalar and v is a real (n-1)-element
  51. *> vector.
  52. *>
  53. *> If the elements of x are all zero, then tau = 0 and H is taken to be
  54. *> the unit matrix.
  55. *>
  56. *> Otherwise 1 <= tau <= 2.
  57. *> \endverbatim
  58. *
  59. * Arguments:
  60. * ==========
  61. *
  62. *> \param[in] N
  63. *> \verbatim
  64. *> N is INTEGER
  65. *> The order of the elementary reflector.
  66. *> \endverbatim
  67. *>
  68. *> \param[in,out] ALPHA
  69. *> \verbatim
  70. *> ALPHA is DOUBLE PRECISION
  71. *> On entry, the value alpha.
  72. *> On exit, it is overwritten with the value beta.
  73. *> \endverbatim
  74. *>
  75. *> \param[in,out] X
  76. *> \verbatim
  77. *> X is DOUBLE PRECISION array, dimension
  78. *> (1+(N-2)*abs(INCX))
  79. *> On entry, the vector x.
  80. *> On exit, it is overwritten with the vector v.
  81. *> \endverbatim
  82. *>
  83. *> \param[in] INCX
  84. *> \verbatim
  85. *> INCX is INTEGER
  86. *> The increment between elements of X. INCX > 0.
  87. *> \endverbatim
  88. *>
  89. *> \param[out] TAU
  90. *> \verbatim
  91. *> TAU is DOUBLE PRECISION
  92. *> The value tau.
  93. *> \endverbatim
  94. *
  95. * Authors:
  96. * ========
  97. *
  98. *> \author Univ. of Tennessee
  99. *> \author Univ. of California Berkeley
  100. *> \author Univ. of Colorado Denver
  101. *> \author NAG Ltd.
  102. *
  103. *> \date September 2012
  104. *
  105. *> \ingroup doubleOTHERauxiliary
  106. *
  107. * =====================================================================
  108. SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
  109. *
  110. * -- LAPACK auxiliary routine (version 3.4.2) --
  111. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  112. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  113. * September 2012
  114. *
  115. * .. Scalar Arguments ..
  116. INTEGER INCX, N
  117. REAL*8 ALPHA, TAU
  118. * ..
  119. * .. Array Arguments ..
  120. REAL*8 X( * )
  121. * ..
  122. *
  123. * =====================================================================
  124. *
  125. * .. Parameters ..
  126. REAL*8 ONE, ZERO
  127. PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  128. * ..
  129. * .. Local Scalars ..
  130. INTEGER J, KNT
  131. REAL*8 BETA, RSAFMN, SAFMIN, XNORM
  132. * ..
  133. * .. External Functions ..
  134. REAL*8 DLAMCH, DLAPY2, DNRM2
  135. EXTERNAL DLAMCH, DLAPY2, DNRM2
  136. * ..
  137. ** .. Intrinsic Functions ..
  138. * INTRINSIC ABS, SIGN
  139. ** ..
  140. ** .. External Subroutines ..
  141. * EXTERNAL DSCAL
  142. ** ..
  143. ** .. Executable Statements ..
  144. *
  145. IF( N.LE.1 ) THEN
  146. TAU = ZERO
  147. RETURN
  148. END IF
  149. *
  150. XNORM = DNRM2( N-1, X, INCX )
  151. *
  152. IF( XNORM.EQ.ZERO ) THEN
  153. *
  154. * H = I
  155. *
  156. TAU = ZERO
  157. ELSE
  158. *
  159. * general case
  160. *
  161. BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
  162. SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
  163. KNT = 0
  164. IF( ABS( BETA ).LT.SAFMIN ) THEN
  165. *
  166. * XNORM, BETA may be inaccurate; scale X and recompute them
  167. *
  168. RSAFMN = ONE / SAFMIN
  169. 10 CONTINUE
  170. KNT = KNT + 1
  171. CALL DSCAL( N-1, RSAFMN, X, INCX )
  172. BETA = BETA*RSAFMN
  173. ALPHA = ALPHA*RSAFMN
  174. IF( ABS( BETA ).LT.SAFMIN )
  175. $ GO TO 10
  176. *
  177. * New BETA is at most 1, at least SAFMIN
  178. *
  179. XNORM = DNRM2( N-1, X, INCX )
  180. BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
  181. END IF
  182. TAU = ( BETA-ALPHA ) / BETA
  183. CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
  184. *
  185. * If ALPHA is subnormal, it may lose relative accuracy
  186. *
  187. DO 20 J = 1, KNT
  188. BETA = BETA*SAFMIN
  189. 20 CONTINUE
  190. ALPHA = BETA
  191. END IF
  192. *
  193. RETURN
  194. *
  195. * End of DLARFG
  196. *
  197. END
  198.  
  199.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales