You can not select more than 25 topics Topics must start with a chinese character,a letter or number, can include dashes ('-') and can be up to 35 characters long.

dormlq.f 9.5 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347
  1. *> \brief \b DORMLQ
  2. *
  3. * =========== DOCUMENTATION ===========
  4. *
  5. * Online html documentation available at
  6. * http://www.netlib.org/lapack/explore-html/
  7. *
  8. *> \htmlonly
  9. *> Download DORMLQ + dependencies
  10. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dormlq.f">
  11. *> [TGZ]</a>
  12. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dormlq.f">
  13. *> [ZIP]</a>
  14. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dormlq.f">
  15. *> [TXT]</a>
  16. *> \endhtmlonly
  17. *
  18. * Definition:
  19. * ===========
  20. *
  21. * SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
  22. * WORK, LWORK, INFO )
  23. *
  24. * .. Scalar Arguments ..
  25. * CHARACTER SIDE, TRANS
  26. * INTEGER INFO, K, LDA, LDC, LWORK, M, N
  27. * ..
  28. * .. Array Arguments ..
  29. * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
  30. * ..
  31. *
  32. *
  33. *> \par Purpose:
  34. * =============
  35. *>
  36. *> \verbatim
  37. *>
  38. *> DORMLQ overwrites the general real M-by-N matrix C with
  39. *>
  40. *> SIDE = 'L' SIDE = 'R'
  41. *> TRANS = 'N': Q * C C * Q
  42. *> TRANS = 'T': Q**T * C C * Q**T
  43. *>
  44. *> where Q is a real orthogonal matrix defined as the product of k
  45. *> elementary reflectors
  46. *>
  47. *> Q = H(k) . . . H(2) H(1)
  48. *>
  49. *> as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N
  50. *> if SIDE = 'R'.
  51. *> \endverbatim
  52. *
  53. * Arguments:
  54. * ==========
  55. *
  56. *> \param[in] SIDE
  57. *> \verbatim
  58. *> SIDE is CHARACTER*1
  59. *> = 'L': apply Q or Q**T from the Left;
  60. *> = 'R': apply Q or Q**T from the Right.
  61. *> \endverbatim
  62. *>
  63. *> \param[in] TRANS
  64. *> \verbatim
  65. *> TRANS is CHARACTER*1
  66. *> = 'N': No transpose, apply Q;
  67. *> = 'T': Transpose, apply Q**T.
  68. *> \endverbatim
  69. *>
  70. *> \param[in] M
  71. *> \verbatim
  72. *> M is INTEGER
  73. *> The number of rows of the matrix C. M >= 0.
  74. *> \endverbatim
  75. *>
  76. *> \param[in] N
  77. *> \verbatim
  78. *> N is INTEGER
  79. *> The number of columns of the matrix C. N >= 0.
  80. *> \endverbatim
  81. *>
  82. *> \param[in] K
  83. *> \verbatim
  84. *> K is INTEGER
  85. *> The number of elementary reflectors whose product defines
  86. *> the matrix Q.
  87. *> If SIDE = 'L', M >= K >= 0;
  88. *> if SIDE = 'R', N >= K >= 0.
  89. *> \endverbatim
  90. *>
  91. *> \param[in] A
  92. *> \verbatim
  93. *> A is DOUBLE PRECISION array, dimension
  94. *> (LDA,M) if SIDE = 'L',
  95. *> (LDA,N) if SIDE = 'R'
  96. *> The i-th row must contain the vector which defines the
  97. *> elementary reflector H(i), for i = 1,2,...,k, as returned by
  98. *> DGELQF in the first k rows of its array argument A.
  99. *> \endverbatim
  100. *>
  101. *> \param[in] LDA
  102. *> \verbatim
  103. *> LDA is INTEGER
  104. *> The leading dimension of the array A. LDA >= max(1,K).
  105. *> \endverbatim
  106. *>
  107. *> \param[in] TAU
  108. *> \verbatim
  109. *> TAU is DOUBLE PRECISION array, dimension (K)
  110. *> TAU(i) must contain the scalar factor of the elementary
  111. *> reflector H(i), as returned by DGELQF.
  112. *> \endverbatim
  113. *>
  114. *> \param[in,out] C
  115. *> \verbatim
  116. *> C is DOUBLE PRECISION array, dimension (LDC,N)
  117. *> On entry, the M-by-N matrix C.
  118. *> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
  119. *> \endverbatim
  120. *>
  121. *> \param[in] LDC
  122. *> \verbatim
  123. *> LDC is INTEGER
  124. *> The leading dimension of the array C. LDC >= max(1,M).
  125. *> \endverbatim
  126. *>
  127. *> \param[out] WORK
  128. *> \verbatim
  129. *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
  130. *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
  131. *> \endverbatim
  132. *>
  133. *> \param[in] LWORK
  134. *> \verbatim
  135. *> LWORK is INTEGER
  136. *> The dimension of the array WORK.
  137. *> If SIDE = 'L', LWORK >= max(1,N);
  138. *> if SIDE = 'R', LWORK >= max(1,M).
  139. *> For good performance, LWORK should generally be larger.
  140. *>
  141. *> If LWORK = -1, then a workspace query is assumed; the routine
  142. *> only calculates the optimal size of the WORK array, returns
  143. *> this value as the first entry of the WORK array, and no error
  144. *> message related to LWORK is issued by XERBLA.
  145. *> \endverbatim
  146. *>
  147. *> \param[out] INFO
  148. *> \verbatim
  149. *> INFO is INTEGER
  150. *> = 0: successful exit
  151. *> < 0: if INFO = -i, the i-th argument had an illegal value
  152. *> \endverbatim
  153. *
  154. * Authors:
  155. * ========
  156. *
  157. *> \author Univ. of Tennessee
  158. *> \author Univ. of California Berkeley
  159. *> \author Univ. of Colorado Denver
  160. *> \author NAG Ltd.
  161. *
  162. *> \date December 2016
  163. *
  164. *> \ingroup doubleOTHERcomputational
  165. *
  166. * =====================================================================
  167. SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
  168. $ WORK, LWORK, INFO )
  169. *
  170. * -- LAPACK computational routine (version 3.7.0) --
  171. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  172. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  173. * December 2016
  174. *
  175. * .. Scalar Arguments ..
  176. CHARACTER SIDE, TRANS
  177. INTEGER INFO, K, LDA, LDC, LWORK, M, N
  178. * ..
  179. * .. Array Arguments ..
  180. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
  181. * ..
  182. *
  183. * =====================================================================
  184. *
  185. * .. Parameters ..
  186. INTEGER NBMAX, LDT, TSIZE
  187. PARAMETER ( NBMAX = 64, LDT = NBMAX+1,
  188. $ TSIZE = LDT*NBMAX )
  189. * ..
  190. * .. Local Scalars ..
  191. LOGICAL LEFT, LQUERY, NOTRAN
  192. CHARACTER TRANST
  193. INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK,
  194. $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
  195. * ..
  196. * .. External Functions ..
  197. LOGICAL LSAME
  198. INTEGER ILAENV
  199. EXTERNAL LSAME, ILAENV
  200. * ..
  201. * .. External Subroutines ..
  202. EXTERNAL DLARFB, DLARFT, DORML2, XERBLA
  203. * ..
  204. * .. Intrinsic Functions ..
  205. INTRINSIC MAX, MIN
  206. * ..
  207. * .. Executable Statements ..
  208. *
  209. * Test the input arguments
  210. *
  211. INFO = 0
  212. LEFT = LSAME( SIDE, 'L' )
  213. NOTRAN = LSAME( TRANS, 'N' )
  214. LQUERY = ( LWORK.EQ.-1 )
  215. *
  216. * NQ is the order of Q and NW is the minimum dimension of WORK
  217. *
  218. IF( LEFT ) THEN
  219. NQ = M
  220. NW = N
  221. ELSE
  222. NQ = N
  223. NW = M
  224. END IF
  225. IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
  226. INFO = -1
  227. ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
  228. INFO = -2
  229. ELSE IF( M.LT.0 ) THEN
  230. INFO = -3
  231. ELSE IF( N.LT.0 ) THEN
  232. INFO = -4
  233. ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
  234. INFO = -5
  235. ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
  236. INFO = -7
  237. ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
  238. INFO = -10
  239. ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
  240. INFO = -12
  241. END IF
  242. *
  243. IF( INFO.EQ.0 ) THEN
  244. *
  245. * Compute the workspace requirements
  246. *
  247. NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K,
  248. $ -1 ) )
  249. LWKOPT = MAX( 1, NW )*NB + TSIZE
  250. WORK( 1 ) = LWKOPT
  251. END IF
  252. *
  253. IF( INFO.NE.0 ) THEN
  254. CALL XERBLA( 'DORMLQ', -INFO )
  255. RETURN
  256. ELSE IF( LQUERY ) THEN
  257. RETURN
  258. END IF
  259. *
  260. * Quick return if possible
  261. *
  262. IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
  263. WORK( 1 ) = 1
  264. RETURN
  265. END IF
  266. *
  267. NBMIN = 2
  268. LDWORK = NW
  269. IF( NB.GT.1 .AND. NB.LT.K ) THEN
  270. IF( LWORK.LT.NW*NB+TSIZE ) THEN
  271. NB = (LWORK-TSIZE) / LDWORK
  272. NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K,
  273. $ -1 ) )
  274. END IF
  275. END IF
  276. *
  277. IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
  278. *
  279. * Use unblocked code
  280. *
  281. CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
  282. $ IINFO )
  283. ELSE
  284. *
  285. * Use blocked code
  286. *
  287. IWT = 1 + NW*NB
  288. IF( ( LEFT .AND. NOTRAN ) .OR.
  289. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
  290. I1 = 1
  291. I2 = K
  292. I3 = NB
  293. ELSE
  294. I1 = ( ( K-1 ) / NB )*NB + 1
  295. I2 = 1
  296. I3 = -NB
  297. END IF
  298. *
  299. IF( LEFT ) THEN
  300. NI = N
  301. JC = 1
  302. ELSE
  303. MI = M
  304. IC = 1
  305. END IF
  306. *
  307. IF( NOTRAN ) THEN
  308. TRANST = 'T'
  309. ELSE
  310. TRANST = 'N'
  311. END IF
  312. *
  313. DO 10 I = I1, I2, I3
  314. IB = MIN( NB, K-I+1 )
  315. *
  316. * Form the triangular factor of the block reflector
  317. * H = H(i) H(i+1) . . . H(i+ib-1)
  318. *
  319. CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
  320. $ LDA, TAU( I ), WORK( IWT ), LDT )
  321. IF( LEFT ) THEN
  322. *
  323. * H or H**T is applied to C(i:m,1:n)
  324. *
  325. MI = M - I + 1
  326. IC = I
  327. ELSE
  328. *
  329. * H or H**T is applied to C(1:m,i:n)
  330. *
  331. NI = N - I + 1
  332. JC = I
  333. END IF
  334. *
  335. * Apply H or H**T
  336. *
  337. CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB,
  338. $ A( I, I ), LDA, WORK( IWT ), LDT,
  339. $ C( IC, JC ), LDC, WORK, LDWORK )
  340. 10 CONTINUE
  341. END IF
  342. WORK( 1 ) = LWKOPT
  343. RETURN
  344. *
  345. * End of DORMLQ
  346. *
  347. END