Télécharger dlaqr1.eso

Retour à la liste

Numérotation des lignes :

  1. C DLAQR1 SOURCE BP208322 20/09/18 21:15:59 10718
  2. *> \brief \b DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts.
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. *> \htmlonly
  10. *> Download DLAQR1 + dependencies
  11. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaqr1.f">
  12. *> [TGZ]</a>
  13. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaqr1.f">
  14. *> [ZIP]</a>
  15. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaqr1.f">
  16. *> [TXT]</a>
  17. *> \endhtmlonly
  18. *
  19. * Definition:
  20. * ===========
  21. *
  22. * SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )
  23. *
  24. * .. Scalar Arguments ..
  25. * REAL*8 SI1, SI2, SR1, SR2
  26. * INTEGER LDH, N
  27. * ..
  28. * .. Array Arguments ..
  29. * REAL*8 H( LDH, * ), V( * )
  30. * ..
  31. *
  32. *
  33. *> \par Purpose:
  34. * =============
  35. *>
  36. *> \verbatim
  37. *>
  38. *> Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a
  39. *> scalar multiple of the first column of the product
  40. *>
  41. *> (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)
  42. *>
  43. *> scaling to avoid overflows and most underflows. It
  44. *> is assumed that either
  45. *>
  46. *> 1) sr1 = sr2 and si1 = -si2
  47. *> or
  48. *> 2) si1 = si2 = 0.
  49. *>
  50. *> This is useful for starting double implicit shift bulges
  51. *> in the QR algorithm.
  52. *> \endverbatim
  53. *
  54. * Arguments:
  55. * ==========
  56. *
  57. *> \param[in] N
  58. *> \verbatim
  59. *> N is INTEGER
  60. *> Order of the matrix H. N must be either 2 or 3.
  61. *> \endverbatim
  62. *>
  63. *> \param[in] H
  64. *> \verbatim
  65. *> H is REAL*8 array, dimension (LDH,N)
  66. *> The 2-by-2 or 3-by-3 matrix H in (*).
  67. *> \endverbatim
  68. *>
  69. *> \param[in] LDH
  70. *> \verbatim
  71. *> LDH is INTEGER
  72. *> The leading dimension of H as declared in
  73. *> the calling procedure. LDH.GE.N
  74. *> \endverbatim
  75. *>
  76. *> \param[in] SR1
  77. *> \verbatim
  78. *> SR1 is REAL*8
  79. *> \endverbatim
  80. *>
  81. *> \param[in] SI1
  82. *> \verbatim
  83. *> SI1 is REAL*8
  84. *> \endverbatim
  85. *>
  86. *> \param[in] SR2
  87. *> \verbatim
  88. *> SR2 is REAL*8
  89. *> \endverbatim
  90. *>
  91. *> \param[in] SI2
  92. *> \verbatim
  93. *> SI2 is REAL*8
  94. *> The shifts in (*).
  95. *> \endverbatim
  96. *>
  97. *> \param[out] V
  98. *> \verbatim
  99. *> V is REAL*8 array, dimension (N)
  100. *> A scalar multiple of the first column of the
  101. *> matrix K in (*).
  102. *> \endverbatim
  103. *
  104. * Authors:
  105. * ========
  106. *
  107. *> \author Univ. of Tennessee
  108. *> \author Univ. of California Berkeley
  109. *> \author Univ. of Colorado Denver
  110. *> \author NAG Ltd.
  111. *
  112. *> \date June 2017
  113. *
  114. *> \ingroup doubleOTHERauxiliary
  115. *
  116. *> \par Contributors:
  117. * ==================
  118. *>
  119. *> Karen Braman and Ralph Byers, Department of Mathematics,
  120. *> University of Kansas, USA
  121. *>
  122. * =====================================================================
  123. SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )
  124. *
  125. * -- LAPACK auxiliary routine (version 3.7.1) --
  126. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  127. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  128. * June 2017
  129.  
  130. IMPLICIT INTEGER(I-N)
  131. IMPLICIT REAL*8(A-H,O-Z)
  132. *
  133. * .. Scalar Arguments ..
  134. REAL*8 SI1, SI2, SR1, SR2
  135. INTEGER LDH, N
  136. * ..
  137. * .. Array Arguments ..
  138. REAL*8 H( LDH, * ), V( * )
  139. * ..
  140. *
  141. * ================================================================
  142. *
  143. * .. Parameters ..
  144. REAL*8 ZERO
  145. PARAMETER ( ZERO = 0.0d0 )
  146. * ..
  147. * .. Local Scalars ..
  148. REAL*8 H21S, H31S, S
  149. * ..
  150. * .. Intrinsic Functions ..
  151. * INTRINSIC ABS
  152. * ..
  153. * .. Executable Statements ..
  154. IF( N.EQ.2 ) THEN
  155. S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) )
  156. IF( S.EQ.ZERO ) THEN
  157. V( 1 ) = ZERO
  158. V( 2 ) = ZERO
  159. ELSE
  160. H21S = H( 2, 1 ) / S
  161. V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )*
  162. $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S )
  163. V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 )
  164. END IF
  165. ELSE
  166. S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) +
  167. $ ABS( H( 3, 1 ) )
  168. IF( S.EQ.ZERO ) THEN
  169. V( 1 ) = ZERO
  170. V( 2 ) = ZERO
  171. V( 3 ) = ZERO
  172. ELSE
  173. H21S = H( 2, 1 ) / S
  174. H31S = H( 3, 1 ) / S
  175. V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) -
  176. $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S
  177. V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) +
  178. $ H( 2, 3 )*H31S
  179. V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) +
  180. $ H21S*H( 3, 2 )
  181. END IF
  182. END IF
  183. END
  184.  
  185.  
  186.  

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