Télécharger dlascl.eso

Retour à la liste

Numérotation des lignes :

  1. C DLASCL SOURCE BP208322 15/10/13 21:15:38 8670
  2. *> \brief \b DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
  3. *
  4. * =========== DOCUMENTATION ===========
  5. *
  6. * Online html documentation available at
  7. * http://www.netlib.org/lapack/explore-html/
  8. *
  9. *> \htmlonly
  10. *> Download DLASCL + dependencies
  11. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlascl.f">
  12. *> [TGZ]</a>
  13. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlascl.f">
  14. *> [ZIP]</a>
  15. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlascl.f">
  16. *> [TXT]</a>
  17. *> \endhtmlonly
  18. *
  19. * Definition:
  20. * ===========
  21. *
  22. * SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
  23. *
  24. * .. Scalar Arguments ..
  25. * CHARACTER TYPE
  26. * INTEGER INFO, KL, KU, LDA, M, N
  27. * REAL*8 CFROM, CTO
  28. * ..
  29. * .. Array Arguments ..
  30. * REAL*8 A( LDA, * )
  31. * ..
  32. *
  33. *
  34. *> \par Purpose:
  35. * =============
  36. *>
  37. *> \verbatim
  38. *>
  39. *> DLASCL multiplies the M by N real matrix A by the real scalar
  40. *> CTO/CFROM. This is done without over/underflow as long as the final
  41. *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
  42. *> A may be full, upper triangular, lower triangular, upper Hessenberg,
  43. *> or banded.
  44. *> \endverbatim
  45. *
  46. * Arguments:
  47. * ==========
  48. *
  49. *> \param[in] TYPE
  50. *> \verbatim
  51. *> TYPE is CHARACTER*1
  52. *> TYPE indices the storage type of the input matrix.
  53. *> = 'G': A is a full matrix.
  54. *> = 'L': A is a lower triangular matrix.
  55. *> = 'U': A is an upper triangular matrix.
  56. *> = 'H': A is an upper Hessenberg matrix.
  57. *> = 'B': A is a symmetric band matrix with lower bandwidth KL
  58. *> and upper bandwidth KU and with the only the lower
  59. *> half stored.
  60. *> = 'Q': A is a symmetric band matrix with lower bandwidth KL
  61. *> and upper bandwidth KU and with the only the upper
  62. *> half stored.
  63. *> = 'Z': A is a band matrix with lower bandwidth KL and upper
  64. *> bandwidth KU. See DGBTRF for storage details.
  65. *> \endverbatim
  66. *>
  67. *> \param[in] KL
  68. *> \verbatim
  69. *> KL is INTEGER
  70. *> The lower bandwidth of A. Referenced only if TYPE = 'B',
  71. *> 'Q' or 'Z'.
  72. *> \endverbatim
  73. *>
  74. *> \param[in] KU
  75. *> \verbatim
  76. *> KU is INTEGER
  77. *> The upper bandwidth of A. Referenced only if TYPE = 'B',
  78. *> 'Q' or 'Z'.
  79. *> \endverbatim
  80. *>
  81. *> \param[in] CFROM
  82. *> \verbatim
  83. *> CFROM is DOUBLE PRECISION
  84. *> \endverbatim
  85. *>
  86. *> \param[in] CTO
  87. *> \verbatim
  88. *> CTO is DOUBLE PRECISION
  89. *>
  90. *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
  91. *> without over/underflow if the final result CTO*A(I,J)/CFROM
  92. *> can be represented without over/underflow. CFROM must be
  93. *> nonzero.
  94. *> \endverbatim
  95. *>
  96. *> \param[in] M
  97. *> \verbatim
  98. *> M is INTEGER
  99. *> The number of rows of the matrix A. M >= 0.
  100. *> \endverbatim
  101. *>
  102. *> \param[in] N
  103. *> \verbatim
  104. *> N is INTEGER
  105. *> The number of columns of the matrix A. N >= 0.
  106. *> \endverbatim
  107. *>
  108. *> \param[in,out] A
  109. *> \verbatim
  110. *> A is DOUBLE PRECISION array, dimension (LDA,N)
  111. *> The matrix to be multiplied by CTO/CFROM. See TYPE for the
  112. *> storage type.
  113. *> \endverbatim
  114. *>
  115. *> \param[in] LDA
  116. *> \verbatim
  117. *> LDA is INTEGER
  118. *> The leading dimension of the array A. LDA >= max(1,M).
  119. *> \endverbatim
  120. *>
  121. *> \param[out] INFO
  122. *> \verbatim
  123. *> INFO is INTEGER
  124. *> 0 - successful exit
  125. *> <0 - if INFO = -i, the i-th argument had an illegal value.
  126. *> \endverbatim
  127. *
  128. * Authors:
  129. * ========
  130. *
  131. *> \author Univ. of Tennessee
  132. *> \author Univ. of California Berkeley
  133. *> \author Univ. of Colorado Denver
  134. *> \author NAG Ltd.
  135. *
  136. *> \date September 2012
  137. *
  138. *> \ingroup auxOTHERauxiliary
  139. *
  140. * =====================================================================
  141. SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
  142. *
  143. * -- LAPACK auxiliary routine (version 3.4.2) --
  144. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  145. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  146. * September 2012
  147. *
  148. * .. Scalar Arguments ..
  149. CHARACTER TYPE
  150. INTEGER INFO, KL, KU, LDA, M, N
  151. REAL*8 CFROM, CTO
  152. * ..
  153. * .. Array Arguments ..
  154. REAL*8 A( LDA, * )
  155. * ..
  156. *
  157. * =====================================================================
  158. *
  159. * .. Parameters ..
  160. REAL*8 ZERO, ONE
  161. PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
  162. * ..
  163. * .. Local Scalars ..
  164. LOGICAL DONE
  165. INTEGER I, ITYPE, J, K1, K2, K3, K4
  166. REAL*8 BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
  167. * ..
  168. * .. External Functions ..
  169. LOGICAL LSAME, DISNAN
  170. REAL*8 DLAMCH
  171. EXTERNAL LSAME, DLAMCH, DISNAN
  172. * ..
  173. ** .. Intrinsic Functions ..
  174. * INTRINSIC ABS, MAX, MIN
  175. ** ..
  176. ** .. External Subroutines ..
  177. EXTERNAL XERBLA
  178. ** ..
  179. ** .. Executable Statements ..
  180. *
  181. * Test the input arguments
  182. *
  183. INFO = 0
  184. *
  185. IF( LSAME( TYPE, 'G' ) ) THEN
  186. ITYPE = 0
  187. ELSE IF( LSAME( TYPE, 'L' ) ) THEN
  188. ITYPE = 1
  189. ELSE IF( LSAME( TYPE, 'U' ) ) THEN
  190. ITYPE = 2
  191. ELSE IF( LSAME( TYPE, 'H' ) ) THEN
  192. ITYPE = 3
  193. ELSE IF( LSAME( TYPE, 'B' ) ) THEN
  194. ITYPE = 4
  195. ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
  196. ITYPE = 5
  197. ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
  198. ITYPE = 6
  199. ELSE
  200. ITYPE = -1
  201. END IF
  202. *
  203. IF( ITYPE.EQ.-1 ) THEN
  204. INFO = -1
  205. ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
  206. INFO = -4
  207. ELSE IF( DISNAN(CTO) ) THEN
  208. INFO = -5
  209. ELSE IF( M.LT.0 ) THEN
  210. INFO = -6
  211. ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
  212. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
  213. INFO = -7
  214. ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
  215. INFO = -9
  216. ELSE IF( ITYPE.GE.4 ) THEN
  217. IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
  218. INFO = -2
  219. ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
  220. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
  221. $ THEN
  222. INFO = -3
  223. ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
  224. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
  225. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
  226. INFO = -9
  227. END IF
  228. END IF
  229. *
  230. IF( INFO.NE.0 ) THEN
  231. CALL XERBLA( 'DLASCL', -INFO )
  232. RETURN
  233. END IF
  234. *
  235. * Quick return if possible
  236. *
  237. IF( N.EQ.0 .OR. M.EQ.0 )
  238. $ RETURN
  239. *
  240. * Get machine parameters
  241. *
  242. SMLNUM = DLAMCH( 'S' )
  243. BIGNUM = ONE / SMLNUM
  244. *
  245. CFROMC = CFROM
  246. CTOC = CTO
  247. *
  248. 10 CONTINUE
  249. CFROM1 = CFROMC*SMLNUM
  250. IF( CFROM1.EQ.CFROMC ) THEN
  251. * CFROMC is an inf. Multiply by a correctly signed zero for
  252. * finite CTOC, or a NaN if CTOC is infinite.
  253. MUL = CTOC / CFROMC
  254. DONE = .TRUE.
  255. CTO1 = CTOC
  256. ELSE
  257. CTO1 = CTOC / BIGNUM
  258. IF( CTO1.EQ.CTOC ) THEN
  259. * CTOC is either 0 or an inf. In both cases, CTOC itself
  260. * serves as the correct multiplication factor.
  261. MUL = CTOC
  262. DONE = .TRUE.
  263. CFROMC = ONE
  264. ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
  265. MUL = SMLNUM
  266. DONE = .FALSE.
  267. CFROMC = CFROM1
  268. ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
  269. MUL = BIGNUM
  270. DONE = .FALSE.
  271. CTOC = CTO1
  272. ELSE
  273. MUL = CTOC / CFROMC
  274. DONE = .TRUE.
  275. END IF
  276. END IF
  277. *
  278. IF( ITYPE.EQ.0 ) THEN
  279. *
  280. * Full matrix
  281. *
  282. DO 30 J = 1, N
  283. DO 20 I = 1, M
  284. A( I, J ) = A( I, J )*MUL
  285. 20 CONTINUE
  286. 30 CONTINUE
  287. *
  288. ELSE IF( ITYPE.EQ.1 ) THEN
  289. *
  290. * Lower triangular matrix
  291. *
  292. DO 50 J = 1, N
  293. DO 40 I = J, M
  294. A( I, J ) = A( I, J )*MUL
  295. 40 CONTINUE
  296. 50 CONTINUE
  297. *
  298. ELSE IF( ITYPE.EQ.2 ) THEN
  299. *
  300. * Upper triangular matrix
  301. *
  302. DO 70 J = 1, N
  303. DO 60 I = 1, MIN( J, M )
  304. A( I, J ) = A( I, J )*MUL
  305. 60 CONTINUE
  306. 70 CONTINUE
  307. *
  308. ELSE IF( ITYPE.EQ.3 ) THEN
  309. *
  310. * Upper Hessenberg matrix
  311. *
  312. DO 90 J = 1, N
  313. DO 80 I = 1, MIN( J+1, M )
  314. A( I, J ) = A( I, J )*MUL
  315. 80 CONTINUE
  316. 90 CONTINUE
  317. *
  318. ELSE IF( ITYPE.EQ.4 ) THEN
  319. *
  320. * Lower half of a symmetric band matrix
  321. *
  322. K3 = KL + 1
  323. K4 = N + 1
  324. DO 110 J = 1, N
  325. DO 100 I = 1, MIN( K3, K4-J )
  326. A( I, J ) = A( I, J )*MUL
  327. 100 CONTINUE
  328. 110 CONTINUE
  329. *
  330. ELSE IF( ITYPE.EQ.5 ) THEN
  331. *
  332. * Upper half of a symmetric band matrix
  333. *
  334. K1 = KU + 2
  335. K3 = KU + 1
  336. DO 130 J = 1, N
  337. DO 120 I = MAX( K1-J, 1 ), K3
  338. A( I, J ) = A( I, J )*MUL
  339. 120 CONTINUE
  340. 130 CONTINUE
  341. *
  342. ELSE IF( ITYPE.EQ.6 ) THEN
  343. *
  344. * Band matrix
  345. *
  346. K1 = KL + KU + 2
  347. K2 = KL + 1
  348. K3 = 2*KL + KU + 1
  349. K4 = KL + KU + 1 + M
  350. DO 150 J = 1, N
  351. DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
  352. A( I, J ) = A( I, J )*MUL
  353. 140 CONTINUE
  354. 150 CONTINUE
  355. *
  356. END IF
  357. *
  358. IF( .NOT.DONE )
  359. $ GO TO 10
  360. *
  361. RETURN
  362. *
  363. * End of DLASCL
  364. *
  365. END
  366.  
  367.  

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