Télécharger dlascl.eso

Retour à la liste

Numérotation des lignes :

dlascl
  1. C DLASCL SOURCE BP208322 18/07/10 21:15:17 9872
  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.
  119. *> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
  120. *> TYPE = 'B', LDA >= KL+1;
  121. *> TYPE = 'Q', LDA >= KU+1;
  122. *> TYPE = 'Z', LDA >= 2*KL+KU+1.
  123. *> \endverbatim
  124. *>
  125. *> \param[out] INFO
  126. *> \verbatim
  127. *> INFO is INTEGER
  128. *> 0 - successful exit
  129. *> <0 - if INFO = -i, the i-th argument had an illegal value.
  130. *> \endverbatim
  131. *
  132. * Authors:
  133. * ========
  134. *
  135. *> \author Univ. of Tennessee
  136. *> \author Univ. of California Berkeley
  137. *> \author Univ. of Colorado Denver
  138. *> \author NAG Ltd.
  139. *
  140. *> \date June 2016
  141. *
  142. *> \ingroup OTHERauxiliary
  143. *
  144. * =====================================================================
  145. SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
  146. *
  147. * -- LAPACK auxiliary routine (version 3.7.0) --
  148. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  149. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  150. * June 2016
  151. *
  152. * .. Scalar Arguments ..
  153. CHARACTER TYPE
  154. INTEGER INFO, KL, KU, LDA, M, N
  155. REAL*8 CFROM, CTO
  156. * ..
  157. * .. Array Arguments ..
  158. REAL*8 A( LDA, * )
  159. * ..
  160. *
  161. * =====================================================================
  162. *
  163. * .. Parameters ..
  164. REAL*8 ZERO, ONE
  165. PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
  166. * ..
  167. * .. Local Scalars ..
  168. LOGICAL DONE
  169. INTEGER I, ITYPE, J, K1, K2, K3, K4
  170. REAL*8 BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
  171. * ..
  172. * .. External Functions ..
  173. LOGICAL LSAME, DISNAN
  174. REAL*8 DLAMCH
  175. EXTERNAL LSAME, DLAMCH, DISNAN
  176. * ..
  177. ** .. Intrinsic Functions ..
  178. * INTRINSIC ABS, MAX, MIN
  179. ** ..
  180. ** .. External Subroutines ..
  181. EXTERNAL XERBLA
  182. ** ..
  183. ** .. Executable Statements ..
  184. *
  185. * Test the input arguments
  186. *
  187. INFO = 0
  188. *
  189. IF( LSAME( TYPE, 'G' ) ) THEN
  190. ITYPE = 0
  191. ELSE IF( LSAME( TYPE, 'L' ) ) THEN
  192. ITYPE = 1
  193. ELSE IF( LSAME( TYPE, 'U' ) ) THEN
  194. ITYPE = 2
  195. ELSE IF( LSAME( TYPE, 'H' ) ) THEN
  196. ITYPE = 3
  197. ELSE IF( LSAME( TYPE, 'B' ) ) THEN
  198. ITYPE = 4
  199. ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
  200. ITYPE = 5
  201. ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
  202. ITYPE = 6
  203. ELSE
  204. ITYPE = -1
  205. END IF
  206. *
  207. IF( ITYPE.EQ.-1 ) THEN
  208. INFO = -1
  209. ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
  210. INFO = -4
  211. ELSE IF( DISNAN(CTO) ) THEN
  212. INFO = -5
  213. ELSE IF( M.LT.0 ) THEN
  214. INFO = -6
  215. ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
  216. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
  217. INFO = -7
  218. ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
  219. INFO = -9
  220. ELSE IF( ITYPE.GE.4 ) THEN
  221. IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
  222. INFO = -2
  223. ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
  224. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
  225. $ THEN
  226. INFO = -3
  227. ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
  228. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
  229. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
  230. INFO = -9
  231. END IF
  232. END IF
  233. *
  234. IF( INFO.NE.0 ) THEN
  235. CALL XERBLA( 'DLASCL', -INFO )
  236. RETURN
  237. END IF
  238. *
  239. * Quick return if possible
  240. *
  241. IF( N.EQ.0 .OR. M.EQ.0 )
  242. $ RETURN
  243. *
  244. * Get machine parameters
  245. *
  246. SMLNUM = DLAMCH( 'S' )
  247. BIGNUM = ONE / SMLNUM
  248. *
  249. CFROMC = CFROM
  250. CTOC = CTO
  251. *
  252. 10 CONTINUE
  253. CFROM1 = CFROMC*SMLNUM
  254. IF( CFROM1.EQ.CFROMC ) THEN
  255. * CFROMC is an inf. Multiply by a correctly signed zero for
  256. * finite CTOC, or a NaN if CTOC is infinite.
  257. MUL = CTOC / CFROMC
  258. DONE = .TRUE.
  259. CTO1 = CTOC
  260. ELSE
  261. CTO1 = CTOC / BIGNUM
  262. IF( CTO1.EQ.CTOC ) THEN
  263. * CTOC is either 0 or an inf. In both cases, CTOC itself
  264. * serves as the correct multiplication factor.
  265. MUL = CTOC
  266. DONE = .TRUE.
  267. CFROMC = ONE
  268. ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
  269. MUL = SMLNUM
  270. DONE = .FALSE.
  271. CFROMC = CFROM1
  272. ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
  273. MUL = BIGNUM
  274. DONE = .FALSE.
  275. CTOC = CTO1
  276. ELSE
  277. MUL = CTOC / CFROMC
  278. DONE = .TRUE.
  279. END IF
  280. END IF
  281. *
  282. IF( ITYPE.EQ.0 ) THEN
  283. *
  284. * Full matrix
  285. *
  286. DO 30 J = 1, N
  287. DO 20 I = 1, M
  288. A( I, J ) = A( I, J )*MUL
  289. 20 CONTINUE
  290. 30 CONTINUE
  291. *
  292. ELSE IF( ITYPE.EQ.1 ) THEN
  293. *
  294. * Lower triangular matrix
  295. *
  296. DO 50 J = 1, N
  297. DO 40 I = J, M
  298. A( I, J ) = A( I, J )*MUL
  299. 40 CONTINUE
  300. 50 CONTINUE
  301. *
  302. ELSE IF( ITYPE.EQ.2 ) THEN
  303. *
  304. * Upper triangular matrix
  305. *
  306. DO 70 J = 1, N
  307. DO 60 I = 1, MIN( J, M )
  308. A( I, J ) = A( I, J )*MUL
  309. 60 CONTINUE
  310. 70 CONTINUE
  311. *
  312. ELSE IF( ITYPE.EQ.3 ) THEN
  313. *
  314. * Upper Hessenberg matrix
  315. *
  316. DO 90 J = 1, N
  317. DO 80 I = 1, MIN( J+1, M )
  318. A( I, J ) = A( I, J )*MUL
  319. 80 CONTINUE
  320. 90 CONTINUE
  321. *
  322. ELSE IF( ITYPE.EQ.4 ) THEN
  323. *
  324. * Lower half of a symmetric band matrix
  325. *
  326. K3 = KL + 1
  327. K4 = N + 1
  328. DO 110 J = 1, N
  329. DO 100 I = 1, MIN( K3, K4-J )
  330. A( I, J ) = A( I, J )*MUL
  331. 100 CONTINUE
  332. 110 CONTINUE
  333. *
  334. ELSE IF( ITYPE.EQ.5 ) THEN
  335. *
  336. * Upper half of a symmetric band matrix
  337. *
  338. K1 = KU + 2
  339. K3 = KU + 1
  340. DO 130 J = 1, N
  341. DO 120 I = MAX( K1-J, 1 ), K3
  342. A( I, J ) = A( I, J )*MUL
  343. 120 CONTINUE
  344. 130 CONTINUE
  345. *
  346. ELSE IF( ITYPE.EQ.6 ) THEN
  347. *
  348. * Band matrix
  349. *
  350. K1 = KL + KU + 2
  351. K2 = KL + 1
  352. K3 = 2*KL + KU + 1
  353. K4 = KL + KU + 1 + M
  354. DO 150 J = 1, N
  355. DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
  356. A( I, J ) = A( I, J )*MUL
  357. 140 CONTINUE
  358. 150 CONTINUE
  359. *
  360. END IF
  361. *
  362. IF( .NOT.DONE )
  363. $ GO TO 10
  364. *
  365. RETURN
  366. *
  367. * End of DLASCL
  368. *
  369. END
  370.  
  371.  
  372.  

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