Télécharger dorm2r.eso

Retour à la liste

Numérotation des lignes :

  1. C DORM2R SOURCE BP208322 15/10/13 21:15:48 8670
  2. *> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm).
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. *> \htmlonly
  10. *> Download DORM2R + dependencies
  11. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorm2r.f">
  12. *> [TGZ]</a>
  13. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorm2r.f">
  14. *> [ZIP]</a>
  15. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorm2r.f">
  16. *> [TXT]</a>
  17. *> \endhtmlonly
  18. *
  19. * Definition:
  20. * ===========
  21. *
  22. * SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
  23. * WORK, INFO )
  24. *
  25. * .. Scalar Arguments ..
  26. * CHARACTER SIDE, TRANS
  27. * INTEGER INFO, K, LDA, LDC, M, N
  28. * ..
  29. * .. Array Arguments ..
  30. * REAL*8 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
  31. * ..
  32. *
  33. *
  34. *> \par Purpose:
  35. * =============
  36. *>
  37. *> \verbatim
  38. *>
  39. *> DORM2R overwrites the general real m by n matrix C with
  40. *>
  41. *> Q * C if SIDE = 'L' and TRANS = 'N', or
  42. *>
  43. *> Q**T* C if SIDE = 'L' and TRANS = 'T', or
  44. *>
  45. *> C * Q if SIDE = 'R' and TRANS = 'N', or
  46. *>
  47. *> C * Q**T if SIDE = 'R' and TRANS = 'T',
  48. *>
  49. *> where Q is a real orthogonal matrix defined as the product of k
  50. *> elementary reflectors
  51. *>
  52. *> Q = H(1) H(2) . . . H(k)
  53. *>
  54. *> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
  55. *> if SIDE = 'R'.
  56. *> \endverbatim
  57. *
  58. * Arguments:
  59. * ==========
  60. *
  61. *> \param[in] SIDE
  62. *> \verbatim
  63. *> SIDE is CHARACTER*1
  64. *> = 'L': apply Q or Q**T from the Left
  65. *> = 'R': apply Q or Q**T from the Right
  66. *> \endverbatim
  67. *>
  68. *> \param[in] TRANS
  69. *> \verbatim
  70. *> TRANS is CHARACTER*1
  71. *> = 'N': apply Q (No transpose)
  72. *> = 'T': apply Q**T (Transpose)
  73. *> \endverbatim
  74. *>
  75. *> \param[in] M
  76. *> \verbatim
  77. *> M is INTEGER
  78. *> The number of rows of the matrix C. M >= 0.
  79. *> \endverbatim
  80. *>
  81. *> \param[in] N
  82. *> \verbatim
  83. *> N is INTEGER
  84. *> The number of columns of the matrix C. N >= 0.
  85. *> \endverbatim
  86. *>
  87. *> \param[in] K
  88. *> \verbatim
  89. *> K is INTEGER
  90. *> The number of elementary reflectors whose product defines
  91. *> the matrix Q.
  92. *> If SIDE = 'L', M >= K >= 0;
  93. *> if SIDE = 'R', N >= K >= 0.
  94. *> \endverbatim
  95. *>
  96. *> \param[in] A
  97. *> \verbatim
  98. *> A is DOUBLE PRECISION array, dimension (LDA,K)
  99. *> The i-th column must contain the vector which defines the
  100. *> elementary reflector H(i), for i = 1,2,...,k, as returned by
  101. *> DGEQRF in the first k columns of its array argument A.
  102. *> A is modified by the routine but restored on exit.
  103. *> \endverbatim
  104. *>
  105. *> \param[in] LDA
  106. *> \verbatim
  107. *> LDA is INTEGER
  108. *> The leading dimension of the array A.
  109. *> If SIDE = 'L', LDA >= max(1,M);
  110. *> if SIDE = 'R', LDA >= max(1,N).
  111. *> \endverbatim
  112. *>
  113. *> \param[in] TAU
  114. *> \verbatim
  115. *> TAU is DOUBLE PRECISION array, dimension (K)
  116. *> TAU(i) must contain the scalar factor of the elementary
  117. *> reflector H(i), as returned by DGEQRF.
  118. *> \endverbatim
  119. *>
  120. *> \param[in,out] C
  121. *> \verbatim
  122. *> C is DOUBLE PRECISION array, dimension (LDC,N)
  123. *> On entry, the m by n matrix C.
  124. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
  125. *> \endverbatim
  126. *>
  127. *> \param[in] LDC
  128. *> \verbatim
  129. *> LDC is INTEGER
  130. *> The leading dimension of the array C. LDC >= max(1,M).
  131. *> \endverbatim
  132. *>
  133. *> \param[out] WORK
  134. *> \verbatim
  135. *> WORK is DOUBLE PRECISION array, dimension
  136. *> (N) if SIDE = 'L',
  137. *> (M) if SIDE = 'R'
  138. *> \endverbatim
  139. *>
  140. *> \param[out] INFO
  141. *> \verbatim
  142. *> INFO is INTEGER
  143. *> = 0: successful exit
  144. *> < 0: if INFO = -i, the i-th argument had an illegal value
  145. *> \endverbatim
  146. *
  147. * Authors:
  148. * ========
  149. *
  150. *> \author Univ. of Tennessee
  151. *> \author Univ. of California Berkeley
  152. *> \author Univ. of Colorado Denver
  153. *> \author NAG Ltd.
  154. *
  155. *> \date September 2012
  156. *
  157. *> \ingroup doubleOTHERcomputational
  158. *
  159. * =====================================================================
  160. SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
  161. $ WORK, INFO )
  162. *
  163. * -- LAPACK computational routine (version 3.4.2) --
  164. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  165. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  166. * September 2012
  167. *
  168. * .. Scalar Arguments ..
  169. CHARACTER SIDE, TRANS
  170. INTEGER INFO, K, LDA, LDC, M, N
  171. * ..
  172. * .. Array Arguments ..
  173. REAL*8 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
  174. * ..
  175. *
  176. * =====================================================================
  177. *
  178. * .. Parameters ..
  179. REAL*8 ONE
  180. PARAMETER ( ONE = 1.0D+0 )
  181. * ..
  182. * .. Local Scalars ..
  183. LOGICAL LEFT, NOTRAN
  184. INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
  185. REAL*8 AII
  186. * ..
  187. * .. External Functions ..
  188. LOGICAL LSAME
  189. EXTERNAL LSAME
  190. * ..
  191. * .. External Subroutines ..
  192. EXTERNAL DLARF, XERBLA
  193. * ..
  194. ** .. Intrinsic Functions ..
  195. * INTRINSIC MAX
  196. ** ..
  197. ** .. Executable Statements ..
  198. *
  199. * Test the input arguments
  200. *
  201. INFO = 0
  202. LEFT = LSAME( SIDE, 'L' )
  203. NOTRAN = LSAME( TRANS, 'N' )
  204. *
  205. * NQ is the order of Q
  206. *
  207. IF( LEFT ) THEN
  208. NQ = M
  209. ELSE
  210. NQ = N
  211. END IF
  212. IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
  213. INFO = -1
  214. ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
  215. INFO = -2
  216. ELSE IF( M.LT.0 ) THEN
  217. INFO = -3
  218. ELSE IF( N.LT.0 ) THEN
  219. INFO = -4
  220. ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
  221. INFO = -5
  222. ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
  223. INFO = -7
  224. ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
  225. INFO = -10
  226. END IF
  227. IF( INFO.NE.0 ) THEN
  228. CALL XERBLA( 'DORM2R', -INFO )
  229. RETURN
  230. END IF
  231. *
  232. * Quick return if possible
  233. *
  234. IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
  235. $ RETURN
  236. *
  237. IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
  238. $ THEN
  239. I1 = 1
  240. I2 = K
  241. I3 = 1
  242. ELSE
  243. I1 = K
  244. I2 = 1
  245. I3 = -1
  246. END IF
  247. *
  248. IF( LEFT ) THEN
  249. NI = N
  250. JC = 1
  251. ELSE
  252. MI = M
  253. IC = 1
  254. END IF
  255. *
  256. DO 10 I = I1, I2, I3
  257. IF( LEFT ) THEN
  258. *
  259. * H(i) is applied to C(i:m,1:n)
  260. *
  261. MI = M - I + 1
  262. IC = I
  263. ELSE
  264. *
  265. * H(i) is applied to C(1:m,i:n)
  266. *
  267. NI = N - I + 1
  268. JC = I
  269. END IF
  270. *
  271. * Apply H(i)
  272. *
  273. AII = A( I, I )
  274. A( I, I ) = ONE
  275. CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
  276. $ LDC, WORK )
  277. A( I, I ) = AII
  278. 10 CONTINUE
  279. RETURN
  280. *
  281. * End of DORM2R
  282. *
  283. END
  284.  
  285.  

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