Télécharger dlarf.eso

Retour à la liste

Numérotation des lignes :

dlarf
  1. C DLARF SOURCE BP208322 18/07/10 21:15:13 9872
  2. *> \brief \b DLARF applies an elementary reflector to a general rectangular matrix.
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. *> \htmlonly
  10. *> Download DLARF + dependencies
  11. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarf.f">
  12. *> [TGZ]</a>
  13. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarf.f">
  14. *> [ZIP]</a>
  15. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarf.f">
  16. *> [TXT]</a>
  17. *> \endhtmlonly
  18. *
  19. * Definition:
  20. * ===========
  21. *
  22. * SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
  23. *
  24. * .. Scalar Arguments ..
  25. * CHARACTER SIDE
  26. * INTEGER INCV, LDC, M, N
  27. * REAL*8 TAU
  28. * ..
  29. * .. Array Arguments ..
  30. * REAL*8 C( LDC, * ), V( * ), WORK( * )
  31. * ..
  32. *
  33. *
  34. *> \par Purpose:
  35. * =============
  36. *>
  37. *> \verbatim
  38. *>
  39. *> DLARF applies a real elementary reflector H to a real m by n matrix
  40. *> C, from either the left or the right. H is represented in the form
  41. *>
  42. *> H = I - tau * v * v**T
  43. *>
  44. *> where tau is a real scalar and v is a real vector.
  45. *>
  46. *> If tau = 0, then H is taken to be the unit matrix.
  47. *> \endverbatim
  48. *
  49. * Arguments:
  50. * ==========
  51. *
  52. *> \param[in] SIDE
  53. *> \verbatim
  54. *> SIDE is CHARACTER*1
  55. *> = 'L': form H * C
  56. *> = 'R': form C * H
  57. *> \endverbatim
  58. *>
  59. *> \param[in] M
  60. *> \verbatim
  61. *> M is INTEGER
  62. *> The number of rows of the matrix C.
  63. *> \endverbatim
  64. *>
  65. *> \param[in] N
  66. *> \verbatim
  67. *> N is INTEGER
  68. *> The number of columns of the matrix C.
  69. *> \endverbatim
  70. *>
  71. *> \param[in] V
  72. *> \verbatim
  73. *> V is DOUBLE PRECISION array, dimension
  74. *> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
  75. *> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
  76. *> The vector v in the representation of H. V is not used if
  77. *> TAU = 0.
  78. *> \endverbatim
  79. *>
  80. *> \param[in] INCV
  81. *> \verbatim
  82. *> INCV is INTEGER
  83. *> The increment between elements of v. INCV <> 0.
  84. *> \endverbatim
  85. *>
  86. *> \param[in] TAU
  87. *> \verbatim
  88. *> TAU is DOUBLE PRECISION
  89. *> The value tau in the representation of H.
  90. *> \endverbatim
  91. *>
  92. *> \param[in,out] C
  93. *> \verbatim
  94. *> C is DOUBLE PRECISION array, dimension (LDC,N)
  95. *> On entry, the m by n matrix C.
  96. *> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
  97. *> or C * H if SIDE = 'R'.
  98. *> \endverbatim
  99. *>
  100. *> \param[in] LDC
  101. *> \verbatim
  102. *> LDC is INTEGER
  103. *> The leading dimension of the array C. LDC >= max(1,M).
  104. *> \endverbatim
  105. *>
  106. *> \param[out] WORK
  107. *> \verbatim
  108. *> WORK is DOUBLE PRECISION array, dimension
  109. *> (N) if SIDE = 'L'
  110. *> or (M) if SIDE = 'R'
  111. *> \endverbatim
  112. *
  113. * Authors:
  114. * ========
  115. *
  116. *> \author Univ. of Tennessee
  117. *> \author Univ. of California Berkeley
  118. *> \author Univ. of Colorado Denver
  119. *> \author NAG Ltd.
  120. *
  121. *> \date December 2016
  122. *
  123. *> \ingroup doubleOTHERauxiliary
  124. *
  125. * =====================================================================
  126. SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
  127. *
  128. * -- LAPACK auxiliary routine (version 3.7.0) --
  129. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  130. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  131. * December 2016
  132. *
  133. * .. Scalar Arguments ..
  134. CHARACTER SIDE
  135. INTEGER INCV, LDC, M, N
  136. REAL*8 TAU
  137. * ..
  138. * .. Array Arguments ..
  139. REAL*8 C( LDC, * ), V( * ), WORK( * )
  140. * ..
  141. *
  142. * =====================================================================
  143. *
  144. * .. Parameters ..
  145. REAL*8 ONE, ZERO
  146. PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  147. * ..
  148. * .. Local Scalars ..
  149. LOGICAL APPLYLEFT
  150. INTEGER I, LASTV, LASTC
  151. * ..
  152. * .. External Subroutines ..
  153. EXTERNAL DGEMV, DGER
  154. * ..
  155. * .. External Functions ..
  156. LOGICAL LSAME
  157. INTEGER ILADLR, ILADLC
  158. EXTERNAL LSAME, ILADLR, ILADLC
  159. * ..
  160. * .. Executable Statements ..
  161. *
  162. APPLYLEFT = LSAME( SIDE, 'L' )
  163. LASTV = 0
  164. LASTC = 0
  165. IF( TAU.NE.ZERO ) THEN
  166. * Set up variables for scanning V. LASTV begins pointing to the end
  167. * of V.
  168. IF( APPLYLEFT ) THEN
  169. LASTV = M
  170. ELSE
  171. LASTV = N
  172. END IF
  173. IF( INCV.GT.0 ) THEN
  174. I = 1 + (LASTV-1) * INCV
  175. ELSE
  176. I = 1
  177. END IF
  178. * Look for the last non-zero row in V.
  179. DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
  180. LASTV = LASTV - 1
  181. I = I - INCV
  182. END DO
  183. IF( APPLYLEFT ) THEN
  184. * Scan for the last non-zero column in C(1:lastv,:).
  185. LASTC = ILADLC(LASTV, N, C, LDC)
  186. ELSE
  187. * Scan for the last non-zero row in C(:,1:lastv).
  188. LASTC = ILADLR(M, LASTV, C, LDC)
  189. END IF
  190. END IF
  191. * Note that lastc.eq.0 renders the BLAS operations null; no special
  192. * case is needed at this level.
  193. IF( APPLYLEFT ) THEN
  194. *
  195. * Form H * C
  196. *
  197. IF( LASTV.GT.0 ) THEN
  198. *
  199. * w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
  200. *
  201. CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
  202. $ ZERO, WORK, 1 )
  203. *
  204. * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
  205. *
  206. CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
  207. END IF
  208. ELSE
  209. *
  210. * Form C * H
  211. *
  212. IF( LASTV.GT.0 ) THEN
  213. *
  214. * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
  215. *
  216. CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
  217. $ V, INCV, ZERO, WORK, 1 )
  218. *
  219. * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
  220. *
  221. CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
  222. END IF
  223. END IF
  224. RETURN
  225. *
  226. * End of DLARF
  227. *
  228. END
  229.  
  230.  
  231.  

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