Télécharger dtrmm.eso

Retour à la liste

Numérotation des lignes :

  1. C DTRMM SOURCE BP208322 15/10/13 21:16:01 8670
  2. SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
  3. $ B, LDB )
  4. * .. Scalar Arguments ..
  5. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
  6. INTEGER M, N, LDA, LDB
  7. REAL*8 ALPHA
  8. * .. Array Arguments ..
  9. REAL*8 A( LDA, * ), B( LDB, * )
  10. * ..
  11. *
  12. * Purpose
  13. * =======
  14. *
  15. * DTRMM performs one of the matrix-matrix operations
  16. *
  17. * B := alpha*op( A )*B, or B := alpha*B*op( A ),
  18. *
  19. * where alpha is a scalar, B is an m by n matrix, A is a unit, or
  20. * non-unit, upper or lower triangular matrix and op( A ) is one of
  21. *
  22. * op( A ) = A or op( A ) = A'.
  23. *
  24. * Parameters
  25. * ==========
  26. *
  27. * SIDE - CHARACTER*1.
  28. * On entry, SIDE specifies whether op( A ) multiplies B from
  29. * the left or right as follows:
  30. *
  31. * SIDE = 'L' or 'l' B := alpha*op( A )*B.
  32. *
  33. * SIDE = 'R' or 'r' B := alpha*B*op( A ).
  34. *
  35. * Unchanged on exit.
  36. *
  37. * UPLO - CHARACTER*1.
  38. * On entry, UPLO specifies whether the matrix A is an upper or
  39. * lower triangular matrix as follows:
  40. *
  41. * UPLO = 'U' or 'u' A is an upper triangular matrix.
  42. *
  43. * UPLO = 'L' or 'l' A is a lower triangular matrix.
  44. *
  45. * Unchanged on exit.
  46. *
  47. * TRANSA - CHARACTER*1.
  48. * On entry, TRANSA specifies the form of op( A ) to be used in
  49. * the matrix multiplication as follows:
  50. *
  51. * TRANSA = 'N' or 'n' op( A ) = A.
  52. *
  53. * TRANSA = 'T' or 't' op( A ) = A'.
  54. *
  55. * TRANSA = 'C' or 'c' op( A ) = A'.
  56. *
  57. * Unchanged on exit.
  58. *
  59. * DIAG - CHARACTER*1.
  60. * On entry, DIAG specifies whether or not A is unit triangular
  61. * as follows:
  62. *
  63. * DIAG = 'U' or 'u' A is assumed to be unit triangular.
  64. *
  65. * DIAG = 'N' or 'n' A is not assumed to be unit
  66. * triangular.
  67. *
  68. * Unchanged on exit.
  69. *
  70. * M - INTEGER.
  71. * On entry, M specifies the number of rows of B. M must be at
  72. * least zero.
  73. * Unchanged on exit.
  74. *
  75. * N - INTEGER.
  76. * On entry, N specifies the number of columns of B. N must be
  77. * at least zero.
  78. * Unchanged on exit.
  79. *
  80. * ALPHA - DOUBLE PRECISION.
  81. * On entry, ALPHA specifies the scalar alpha. When alpha is
  82. * zero then A is not referenced and B need not be set before
  83. * entry.
  84. * Unchanged on exit.
  85. *
  86. * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
  87. * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
  88. * Before entry with UPLO = 'U' or 'u', the leading k by k
  89. * upper triangular part of the array A must contain the upper
  90. * triangular matrix and the strictly lower triangular part of
  91. * A is not referenced.
  92. * Before entry with UPLO = 'L' or 'l', the leading k by k
  93. * lower triangular part of the array A must contain the lower
  94. * triangular matrix and the strictly upper triangular part of
  95. * A is not referenced.
  96. * Note that when DIAG = 'U' or 'u', the diagonal elements of
  97. * A are not referenced either, but are assumed to be unity.
  98. * Unchanged on exit.
  99. *
  100. * LDA - INTEGER.
  101. * On entry, LDA specifies the first dimension of A as declared
  102. * in the calling (sub) program. When SIDE = 'L' or 'l' then
  103. * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
  104. * then LDA must be at least max( 1, n ).
  105. * Unchanged on exit.
  106. *
  107. * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
  108. * Before entry, the leading m by n part of the array B must
  109. * contain the matrix B, and on exit is overwritten by the
  110. * transformed matrix.
  111. *
  112. * LDB - INTEGER.
  113. * On entry, LDB specifies the first dimension of B as declared
  114. * in the calling (sub) program. LDB must be at least
  115. * max( 1, m ).
  116. * Unchanged on exit.
  117. *
  118. *
  119. * Level 3 Blas routine.
  120. *
  121. * -- Written on 8-February-1989.
  122. * Jack Dongarra, Argonne National Laboratory.
  123. * Iain Duff, AERE Harwell.
  124. * Jeremy Du Croz, Numerical Algorithms Group Ltd.
  125. * Sven Hammarling, Numerical Algorithms Group Ltd.
  126. *
  127. *
  128. * .. External Functions ..
  129. LOGICAL LSAME
  130. EXTERNAL LSAME
  131. * .. External Subroutines ..
  132. EXTERNAL XERBLA
  133. ** .. Intrinsic Functions ..
  134. * INTRINSIC MAX
  135. ** .. Local Scalars ..
  136. LOGICAL LSIDE, NOUNIT, UPPER
  137. INTEGER I, INFO, J, K, NROWA
  138. REAL*8 TEMP
  139. ** .. Parameters ..
  140. REAL*8 ONE , ZERO
  141. PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  142. ** ..
  143. ** .. Executable Statements ..
  144. *
  145. * Test the input parameters.
  146. *
  147. LSIDE = LSAME( SIDE , 'L' )
  148. IF( LSIDE )THEN
  149. NROWA = M
  150. ELSE
  151. NROWA = N
  152. END IF
  153. NOUNIT = LSAME( DIAG , 'N' )
  154. UPPER = LSAME( UPLO , 'U' )
  155. *
  156. INFO = 0
  157. IF( ( .NOT.LSIDE ).AND.
  158. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN
  159. INFO = 1
  160. ELSE IF( ( .NOT.UPPER ).AND.
  161. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN
  162. INFO = 2
  163. ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
  164. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
  165. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN
  166. INFO = 3
  167. ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND.
  168. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN
  169. INFO = 4
  170. ELSE IF( M .LT.0 )THEN
  171. INFO = 5
  172. ELSE IF( N .LT.0 )THEN
  173. INFO = 6
  174. ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
  175. INFO = 9
  176. ELSE IF( LDB.LT.MAX( 1, M ) )THEN
  177. INFO = 11
  178. END IF
  179. IF( INFO.NE.0 )THEN
  180. CALL XERBLA( 'DTRMM ', INFO )
  181. RETURN
  182. END IF
  183. *
  184. * Quick return if possible.
  185. *
  186. IF( N.EQ.0 )
  187. $ RETURN
  188. *
  189. * And when alpha.eq.zero.
  190. *
  191. IF( ALPHA.EQ.ZERO )THEN
  192. DO 20, J = 1, N
  193. DO 10, I = 1, M
  194. B( I, J ) = ZERO
  195. 10 CONTINUE
  196. 20 CONTINUE
  197. RETURN
  198. END IF
  199. *
  200. * Start the operations.
  201. *
  202. IF( LSIDE )THEN
  203. IF( LSAME( TRANSA, 'N' ) )THEN
  204. *
  205. * Form B := alpha*A*B.
  206. *
  207. IF( UPPER )THEN
  208. DO 50, J = 1, N
  209. DO 40, K = 1, M
  210. IF( B( K, J ).NE.ZERO )THEN
  211. TEMP = ALPHA*B( K, J )
  212. DO 30, I = 1, K - 1
  213. B( I, J ) = B( I, J ) + TEMP*A( I, K )
  214. 30 CONTINUE
  215. IF( NOUNIT )
  216. $ TEMP = TEMP*A( K, K )
  217. B( K, J ) = TEMP
  218. END IF
  219. 40 CONTINUE
  220. 50 CONTINUE
  221. ELSE
  222. DO 80, J = 1, N
  223. DO 70 K = M, 1, -1
  224. IF( B( K, J ).NE.ZERO )THEN
  225. TEMP = ALPHA*B( K, J )
  226. B( K, J ) = TEMP
  227. IF( NOUNIT )
  228. $ B( K, J ) = B( K, J )*A( K, K )
  229. DO 60, I = K + 1, M
  230. B( I, J ) = B( I, J ) + TEMP*A( I, K )
  231. 60 CONTINUE
  232. END IF
  233. 70 CONTINUE
  234. 80 CONTINUE
  235. END IF
  236. ELSE
  237. *
  238. * Form B := alpha*B*A'.
  239. *
  240. IF( UPPER )THEN
  241. DO 110, J = 1, N
  242. DO 100, I = M, 1, -1
  243. TEMP = B( I, J )
  244. IF( NOUNIT )
  245. $ TEMP = TEMP*A( I, I )
  246. DO 90, K = 1, I - 1
  247. TEMP = TEMP + A( K, I )*B( K, J )
  248. 90 CONTINUE
  249. B( I, J ) = ALPHA*TEMP
  250. 100 CONTINUE
  251. 110 CONTINUE
  252. ELSE
  253. DO 140, J = 1, N
  254. DO 130, I = 1, M
  255. TEMP = B( I, J )
  256. IF( NOUNIT )
  257. $ TEMP = TEMP*A( I, I )
  258. DO 120, K = I + 1, M
  259. TEMP = TEMP + A( K, I )*B( K, J )
  260. 120 CONTINUE
  261. B( I, J ) = ALPHA*TEMP
  262. 130 CONTINUE
  263. 140 CONTINUE
  264. END IF
  265. END IF
  266. ELSE
  267. IF( LSAME( TRANSA, 'N' ) )THEN
  268. *
  269. * Form B := alpha*B*A.
  270. *
  271. IF( UPPER )THEN
  272. DO 180, J = N, 1, -1
  273. TEMP = ALPHA
  274. IF( NOUNIT )
  275. $ TEMP = TEMP*A( J, J )
  276. DO 150, I = 1, M
  277. B( I, J ) = TEMP*B( I, J )
  278. 150 CONTINUE
  279. DO 170, K = 1, J - 1
  280. IF( A( K, J ).NE.ZERO )THEN
  281. TEMP = ALPHA*A( K, J )
  282. DO 160, I = 1, M
  283. B( I, J ) = B( I, J ) + TEMP*B( I, K )
  284. 160 CONTINUE
  285. END IF
  286. 170 CONTINUE
  287. 180 CONTINUE
  288. ELSE
  289. DO 220, J = 1, N
  290. TEMP = ALPHA
  291. IF( NOUNIT )
  292. $ TEMP = TEMP*A( J, J )
  293. DO 190, I = 1, M
  294. B( I, J ) = TEMP*B( I, J )
  295. 190 CONTINUE
  296. DO 210, K = J + 1, N
  297. IF( A( K, J ).NE.ZERO )THEN
  298. TEMP = ALPHA*A( K, J )
  299. DO 200, I = 1, M
  300. B( I, J ) = B( I, J ) + TEMP*B( I, K )
  301. 200 CONTINUE
  302. END IF
  303. 210 CONTINUE
  304. 220 CONTINUE
  305. END IF
  306. ELSE
  307. *
  308. * Form B := alpha*B*A'.
  309. *
  310. IF( UPPER )THEN
  311. DO 260, K = 1, N
  312. DO 240, J = 1, K - 1
  313. IF( A( J, K ).NE.ZERO )THEN
  314. TEMP = ALPHA*A( J, K )
  315. DO 230, I = 1, M
  316. B( I, J ) = B( I, J ) + TEMP*B( I, K )
  317. 230 CONTINUE
  318. END IF
  319. 240 CONTINUE
  320. TEMP = ALPHA
  321. IF( NOUNIT )
  322. $ TEMP = TEMP*A( K, K )
  323. IF( TEMP.NE.ONE )THEN
  324. DO 250, I = 1, M
  325. B( I, K ) = TEMP*B( I, K )
  326. 250 CONTINUE
  327. END IF
  328. 260 CONTINUE
  329. ELSE
  330. DO 300, K = N, 1, -1
  331. DO 280, J = K + 1, N
  332. IF( A( J, K ).NE.ZERO )THEN
  333. TEMP = ALPHA*A( J, K )
  334. DO 270, I = 1, M
  335. B( I, J ) = B( I, J ) + TEMP*B( I, K )
  336. 270 CONTINUE
  337. END IF
  338. 280 CONTINUE
  339. TEMP = ALPHA
  340. IF( NOUNIT )
  341. $ TEMP = TEMP*A( K, K )
  342. IF( TEMP.NE.ONE )THEN
  343. DO 290, I = 1, M
  344. B( I, K ) = TEMP*B( I, K )
  345. 290 CONTINUE
  346. END IF
  347. 300 CONTINUE
  348. END IF
  349. END IF
  350. END IF
  351. *
  352. RETURN
  353. *
  354. * End of DTRMM .
  355. *
  356. END
  357.  
  358.  

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