Télécharger dtrsm.eso

Retour à la liste

Numérotation des lignes :

  1. C DTRSM SOURCE BP208322 20/09/18 21:16:15 10718
  2. *> \brief \b DTRSM
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. * Definition:
  10. * ===========
  11. *
  12. * SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
  13. *
  14. * .. Scalar Arguments ..
  15. * REAL ALPHA
  16. * INTEGER LDA,LDB,M,N
  17. * CHARACTER DIAG,SIDE,TRANSA,UPLO
  18. * ..
  19. * .. Array Arguments ..
  20. * REAL A(LDA,*),B(LDB,*)
  21. * ..
  22. *
  23. *
  24. *> \par Purpose:
  25. * =============
  26. *>
  27. *> \verbatim
  28. *>
  29. *> STRSM solves one of the matrix equations
  30. *>
  31. *> op( A )*X = alpha*B, or X*op( A ) = alpha*B,
  32. *>
  33. *> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
  34. *> non-unit, upper or lower triangular matrix and op( A ) is one of
  35. *>
  36. *> op( A ) = A or op( A ) = A**T.
  37. *>
  38. *> The matrix X is overwritten on B.
  39. *> \endverbatim
  40. *
  41. * Arguments:
  42. * ==========
  43. *
  44. *> \param[in] SIDE
  45. *> \verbatim
  46. *> SIDE is CHARACTER*1
  47. *> On entry, SIDE specifies whether op( A ) appears on the left
  48. *> or right of X as follows:
  49. *>
  50. *> SIDE = 'L' or 'l' op( A )*X = alpha*B.
  51. *>
  52. *> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
  53. *> \endverbatim
  54. *>
  55. *> \param[in] UPLO
  56. *> \verbatim
  57. *> UPLO is CHARACTER*1
  58. *> On entry, UPLO specifies whether the matrix A is an upper or
  59. *> lower triangular matrix as follows:
  60. *>
  61. *> UPLO = 'U' or 'u' A is an upper triangular matrix.
  62. *>
  63. *> UPLO = 'L' or 'l' A is a lower triangular matrix.
  64. *> \endverbatim
  65. *>
  66. *> \param[in] TRANSA
  67. *> \verbatim
  68. *> TRANSA is CHARACTER*1
  69. *> On entry, TRANSA specifies the form of op( A ) to be used in
  70. *> the matrix multiplication as follows:
  71. *>
  72. *> TRANSA = 'N' or 'n' op( A ) = A.
  73. *>
  74. *> TRANSA = 'T' or 't' op( A ) = A**T.
  75. *>
  76. *> TRANSA = 'C' or 'c' op( A ) = A**T.
  77. *> \endverbatim
  78. *>
  79. *> \param[in] DIAG
  80. *> \verbatim
  81. *> DIAG is CHARACTER*1
  82. *> On entry, DIAG specifies whether or not A is unit triangular
  83. *> as follows:
  84. *>
  85. *> DIAG = 'U' or 'u' A is assumed to be unit triangular.
  86. *>
  87. *> DIAG = 'N' or 'n' A is not assumed to be unit
  88. *> triangular.
  89. *> \endverbatim
  90. *>
  91. *> \param[in] M
  92. *> \verbatim
  93. *> M is INTEGER
  94. *> On entry, M specifies the number of rows of B. M must be at
  95. *> least zero.
  96. *> \endverbatim
  97. *>
  98. *> \param[in] N
  99. *> \verbatim
  100. *> N is INTEGER
  101. *> On entry, N specifies the number of columns of B. N must be
  102. *> at least zero.
  103. *> \endverbatim
  104. *>
  105. *> \param[in] ALPHA
  106. *> \verbatim
  107. *> ALPHA is REAL
  108. *> On entry, ALPHA specifies the scalar alpha. When alpha is
  109. *> zero then A is not referenced and B need not be set before
  110. *> entry.
  111. *> \endverbatim
  112. *>
  113. *> \param[in] A
  114. *> \verbatim
  115. *> A is REAL array, dimension ( LDA, k ),
  116. *> where k is m when SIDE = 'L' or 'l'
  117. *> and k is n when SIDE = 'R' or 'r'.
  118. *> Before entry with UPLO = 'U' or 'u', the leading k by k
  119. *> upper triangular part of the array A must contain the upper
  120. *> triangular matrix and the strictly lower triangular part of
  121. *> A is not referenced.
  122. *> Before entry with UPLO = 'L' or 'l', the leading k by k
  123. *> lower triangular part of the array A must contain the lower
  124. *> triangular matrix and the strictly upper triangular part of
  125. *> A is not referenced.
  126. *> Note that when DIAG = 'U' or 'u', the diagonal elements of
  127. *> A are not referenced either, but are assumed to be unity.
  128. *> \endverbatim
  129. *>
  130. *> \param[in] LDA
  131. *> \verbatim
  132. *> LDA is INTEGER
  133. *> On entry, LDA specifies the first dimension of A as declared
  134. *> in the calling (sub) program. When SIDE = 'L' or 'l' then
  135. *> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
  136. *> then LDA must be at least max( 1, n ).
  137. *> \endverbatim
  138. *>
  139. *> \param[in,out] B
  140. *> \verbatim
  141. *> B is REAL array, dimension ( LDB, N )
  142. *> Before entry, the leading m by n part of the array B must
  143. *> contain the right-hand side matrix B, and on exit is
  144. *> overwritten by the solution matrix X.
  145. *> \endverbatim
  146. *>
  147. *> \param[in] LDB
  148. *> \verbatim
  149. *> LDB is INTEGER
  150. *> On entry, LDB specifies the first dimension of B as declared
  151. *> in the calling (sub) program. LDB must be at least
  152. *> max( 1, m ).
  153. *> \endverbatim
  154. *
  155. * Authors:
  156. * ========
  157. *
  158. *> \author Univ. of Tennessee
  159. *> \author Univ. of California Berkeley
  160. *> \author Univ. of Colorado Denver
  161. *> \author NAG Ltd.
  162. *
  163. *> \date December 2016
  164. *
  165. *> \ingroup single_blas_level3
  166. *
  167. *> \par Further Details:
  168. * =====================
  169. *>
  170. *> \verbatim
  171. *>
  172. *> Level 3 Blas routine.
  173. *>
  174. *>
  175. *> -- Written on 8-February-1989.
  176. *> Jack Dongarra, Argonne National Laboratory.
  177. *> Iain Duff, AERE Harwell.
  178. *> Jeremy Du Croz, Numerical Algorithms Group Ltd.
  179. *> Sven Hammarling, Numerical Algorithms Group Ltd.
  180. *> \endverbatim
  181. *>
  182. * =====================================================================
  183. SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
  184. *
  185. * -- Reference BLAS level3 routine (version 3.7.0) --
  186. * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
  187. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  188. * December 2016
  189.  
  190. IMPLICIT INTEGER(I-N)
  191. IMPLICIT REAL*8(A-H,O-Z)
  192. *
  193. * .. Scalar Arguments ..
  194. REAL*8 ALPHA
  195. INTEGER LDA,LDB,M,N
  196. CHARACTER DIAG,SIDE,TRANSA,UPLO
  197. * ..
  198. * .. Array Arguments ..
  199. REAL*8 A(LDA,*),B(LDB,*)
  200. * ..
  201. *
  202. * =====================================================================
  203. * ..
  204. * .. External Subroutines ..
  205. * EXTERNAL XERBLA
  206. * ..
  207. * .. Intrinsic Functions ..
  208. * INTRINSIC MAX
  209. * ..
  210. * .. Parameters ..
  211. REAL*8 ONE, ZERO
  212. PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  213.  
  214. * .. Local Scalars ..
  215. REAL*8 TEMP
  216. INTEGER I,INFO,J,K,NROWA
  217. LOGICAL LSIDE,NOUNIT,UPPER
  218. * ..
  219. * ..
  220. *
  221. * Test the input parameters.
  222. *
  223. LSIDE = (SIDE.EQ.'L')
  224. IF (LSIDE) THEN
  225. NROWA = M
  226. ELSE
  227. NROWA = N
  228. END IF
  229. NOUNIT = (DIAG.EQ.'N')
  230. UPPER = (UPLO.EQ.'U')
  231. *
  232. INFO = 0
  233. IF ((.NOT.LSIDE) .AND. (.NOT.(SIDE.EQ.'R'))) THEN
  234. INFO = 1
  235. ELSE IF ((.NOT.UPPER) .AND. (.NOT.(UPLO.EQ.'L'))) THEN
  236. INFO = 2
  237. ELSE IF ((.NOT.(TRANSA.EQ.'N')) .AND.
  238. + (.NOT.(TRANSA.EQ.'T')) .AND.
  239. + (.NOT.(TRANSA.EQ.'C'))) THEN
  240. INFO = 3
  241. ELSE IF ((.NOT.(DIAG.EQ.'U')) .AND. (.NOT.(DIAG.EQ.'N'))) THEN
  242. INFO = 4
  243. ELSE IF (M.LT.0) THEN
  244. INFO = 5
  245. ELSE IF (N.LT.0) THEN
  246. INFO = 6
  247. ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
  248. INFO = 9
  249. ELSE IF (LDB.LT.MAX(1,M)) THEN
  250. INFO = 11
  251. END IF
  252. IF (INFO.NE.0) THEN
  253. CALL XERBLA('DTRSM ',INFO)
  254. RETURN
  255. END IF
  256. *
  257. * Quick return if possible.
  258. *
  259. IF (M.EQ.0 .OR. N.EQ.0) RETURN
  260. *
  261. * And when alpha.eq.zero.
  262. *
  263. IF (ALPHA.EQ.ZERO) THEN
  264. DO 20 J = 1,N
  265. DO 10 I = 1,M
  266. B(I,J) = ZERO
  267. 10 CONTINUE
  268. 20 CONTINUE
  269. RETURN
  270. END IF
  271. *
  272. * Start the operations.
  273. *
  274. IF (LSIDE) THEN
  275. IF ((TRANSA.EQ.'N')) THEN
  276. *
  277. * Form B := alpha*inv( A )*B.
  278. *
  279. IF (UPPER) THEN
  280. DO 60 J = 1,N
  281. IF (ALPHA.NE.ONE) THEN
  282. DO 30 I = 1,M
  283. B(I,J) = ALPHA*B(I,J)
  284. 30 CONTINUE
  285. END IF
  286. DO 50 K = M,1,-1
  287. IF (B(K,J).NE.ZERO) THEN
  288. IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
  289. DO 40 I = 1,K - 1
  290. B(I,J) = B(I,J) - B(K,J)*A(I,K)
  291. 40 CONTINUE
  292. END IF
  293. 50 CONTINUE
  294. 60 CONTINUE
  295. ELSE
  296. DO 100 J = 1,N
  297. IF (ALPHA.NE.ONE) THEN
  298. DO 70 I = 1,M
  299. B(I,J) = ALPHA*B(I,J)
  300. 70 CONTINUE
  301. END IF
  302. DO 90 K = 1,M
  303. IF (B(K,J).NE.ZERO) THEN
  304. IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
  305. DO 80 I = K + 1,M
  306. B(I,J) = B(I,J) - B(K,J)*A(I,K)
  307. 80 CONTINUE
  308. END IF
  309. 90 CONTINUE
  310. 100 CONTINUE
  311. END IF
  312. ELSE
  313. *
  314. * Form B := alpha*inv( A**T )*B.
  315. *
  316. IF (UPPER) THEN
  317. DO 130 J = 1,N
  318. DO 120 I = 1,M
  319. TEMP = ALPHA*B(I,J)
  320. DO 110 K = 1,I - 1
  321. TEMP = TEMP - A(K,I)*B(K,J)
  322. 110 CONTINUE
  323. IF (NOUNIT) TEMP = TEMP/A(I,I)
  324. B(I,J) = TEMP
  325. 120 CONTINUE
  326. 130 CONTINUE
  327. ELSE
  328. DO 160 J = 1,N
  329. DO 150 I = M,1,-1
  330. TEMP = ALPHA*B(I,J)
  331. DO 140 K = I + 1,M
  332. TEMP = TEMP - A(K,I)*B(K,J)
  333. 140 CONTINUE
  334. IF (NOUNIT) TEMP = TEMP/A(I,I)
  335. B(I,J) = TEMP
  336. 150 CONTINUE
  337. 160 CONTINUE
  338. END IF
  339. END IF
  340. ELSE
  341. IF ((TRANSA.EQ.'N')) THEN
  342. *
  343. * Form B := alpha*B*inv( A ).
  344. *
  345. IF (UPPER) THEN
  346. DO 210 J = 1,N
  347. IF (ALPHA.NE.ONE) THEN
  348. DO 170 I = 1,M
  349. B(I,J) = ALPHA*B(I,J)
  350. 170 CONTINUE
  351. END IF
  352. DO 190 K = 1,J - 1
  353. IF (A(K,J).NE.ZERO) THEN
  354. DO 180 I = 1,M
  355. B(I,J) = B(I,J) - A(K,J)*B(I,K)
  356. 180 CONTINUE
  357. END IF
  358. 190 CONTINUE
  359. IF (NOUNIT) THEN
  360. TEMP = ONE/A(J,J)
  361. DO 200 I = 1,M
  362. B(I,J) = TEMP*B(I,J)
  363. 200 CONTINUE
  364. END IF
  365. 210 CONTINUE
  366. ELSE
  367. DO 260 J = N,1,-1
  368. IF (ALPHA.NE.ONE) THEN
  369. DO 220 I = 1,M
  370. B(I,J) = ALPHA*B(I,J)
  371. 220 CONTINUE
  372. END IF
  373. DO 240 K = J + 1,N
  374. IF (A(K,J).NE.ZERO) THEN
  375. DO 230 I = 1,M
  376. B(I,J) = B(I,J) - A(K,J)*B(I,K)
  377. 230 CONTINUE
  378. END IF
  379. 240 CONTINUE
  380. IF (NOUNIT) THEN
  381. TEMP = ONE/A(J,J)
  382. DO 250 I = 1,M
  383. B(I,J) = TEMP*B(I,J)
  384. 250 CONTINUE
  385. END IF
  386. 260 CONTINUE
  387. END IF
  388. ELSE
  389. *
  390. * Form B := alpha*B*inv( A**T ).
  391. *
  392. IF (UPPER) THEN
  393. DO 310 K = N,1,-1
  394. IF (NOUNIT) THEN
  395. TEMP = ONE/A(K,K)
  396. DO 270 I = 1,M
  397. B(I,K) = TEMP*B(I,K)
  398. 270 CONTINUE
  399. END IF
  400. DO 290 J = 1,K - 1
  401. IF (A(J,K).NE.ZERO) THEN
  402. TEMP = A(J,K)
  403. DO 280 I = 1,M
  404. B(I,J) = B(I,J) - TEMP*B(I,K)
  405. 280 CONTINUE
  406. END IF
  407. 290 CONTINUE
  408. IF (ALPHA.NE.ONE) THEN
  409. DO 300 I = 1,M
  410. B(I,K) = ALPHA*B(I,K)
  411. 300 CONTINUE
  412. END IF
  413. 310 CONTINUE
  414. ELSE
  415. DO 360 K = 1,N
  416. IF (NOUNIT) THEN
  417. TEMP = ONE/A(K,K)
  418. DO 320 I = 1,M
  419. B(I,K) = TEMP*B(I,K)
  420. 320 CONTINUE
  421. END IF
  422. DO 340 J = K + 1,N
  423. IF (A(J,K).NE.ZERO) THEN
  424. TEMP = A(J,K)
  425. DO 330 I = 1,M
  426. B(I,J) = B(I,J) - TEMP*B(I,K)
  427. 330 CONTINUE
  428. END IF
  429. 340 CONTINUE
  430. IF (ALPHA.NE.ONE) THEN
  431. DO 350 I = 1,M
  432. B(I,K) = ALPHA*B(I,K)
  433. 350 CONTINUE
  434. END IF
  435. 360 CONTINUE
  436. END IF
  437. END IF
  438. END IF
  439. *
  440. RETURN
  441. *
  442. * End of DTRSM .
  443. *
  444. END
  445.  
  446.  
  447.  
  448.  

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