Statistiques
| Révision :

root / src / lapack / double / dlascl.f @ 10

Historique | Voir | Annoter | Télécharger (7,76 ko)

1 1 pfleura2 
      SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
2 1 pfleura2 
*
3 1 pfleura2 
*  -- LAPACK auxiliary routine (version 3.2) --
4 1 pfleura2 
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
5 1 pfleura2 
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6 1 pfleura2 
*     November 2006
7 1 pfleura2 
*
8 1 pfleura2 
*     .. Scalar Arguments ..
9 1 pfleura2 
      CHARACTER          TYPE
10 1 pfleura2 
      INTEGER            INFO, KL, KU, LDA, M, N
11 1 pfleura2 
      DOUBLE PRECISION   CFROM, CTO
12 1 pfleura2 
*     ..
13 1 pfleura2 
*     .. Array Arguments ..
14 1 pfleura2 
      DOUBLE PRECISION   A( LDA, * )
15 1 pfleura2 
*     ..
16 1 pfleura2 
*
17 1 pfleura2 
*  Purpose
18 1 pfleura2 
*  =======
19 1 pfleura2 
*
20 1 pfleura2 
*  DLASCL multiplies the M by N real matrix A by the real scalar
21 1 pfleura2 
*  CTO/CFROM.  This is done without over/underflow as long as the final
22 1 pfleura2 
*  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
23 1 pfleura2 
*  A may be full, upper triangular, lower triangular, upper Hessenberg,
24 1 pfleura2 
*  or banded.
25 1 pfleura2 
*
26 1 pfleura2 
*  Arguments
27 1 pfleura2 
*  =========
28 1 pfleura2 
*
29 1 pfleura2 
*  TYPE    (input) CHARACTER*1
30 1 pfleura2 
*          TYPE indices the storage type of the input matrix.
31 1 pfleura2 
*          = 'G':  A is a full matrix.
32 1 pfleura2 
*          = 'L':  A is a lower triangular matrix.
33 1 pfleura2 
*          = 'U':  A is an upper triangular matrix.
34 1 pfleura2 
*          = 'H':  A is an upper Hessenberg matrix.
35 1 pfleura2 
*          = 'B':  A is a symmetric band matrix with lower bandwidth KL
36 1 pfleura2 
*                  and upper bandwidth KU and with the only the lower
37 1 pfleura2 
*                  half stored.
38 1 pfleura2 
*          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
39 1 pfleura2 
*                  and upper bandwidth KU and with the only the upper
40 1 pfleura2 
*                  half stored.
41 1 pfleura2 
*          = 'Z':  A is a band matrix with lower bandwidth KL and upper
42 1 pfleura2 
*                  bandwidth KU.
43 1 pfleura2 
*
44 1 pfleura2 
*  KL      (input) INTEGER
45 1 pfleura2 
*          The lower bandwidth of A.  Referenced only if TYPE = 'B',
46 1 pfleura2 
*          'Q' or 'Z'.
47 1 pfleura2 
*
48 1 pfleura2 
*  KU      (input) INTEGER
49 1 pfleura2 
*          The upper bandwidth of A.  Referenced only if TYPE = 'B',
50 1 pfleura2 
*          'Q' or 'Z'.
51 1 pfleura2 
*
52 1 pfleura2 
*  CFROM   (input) DOUBLE PRECISION
53 1 pfleura2 
*  CTO     (input) DOUBLE PRECISION
54 1 pfleura2 
*          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
55 1 pfleura2 
*          without over/underflow if the final result CTO*A(I,J)/CFROM
56 1 pfleura2 
*          can be represented without over/underflow.  CFROM must be
57 1 pfleura2 
*          nonzero.
58 1 pfleura2 
*
59 1 pfleura2 
*  M       (input) INTEGER
60 1 pfleura2 
*          The number of rows of the matrix A.  M >= 0.
61 1 pfleura2 
*
62 1 pfleura2 
*  N       (input) INTEGER
63 1 pfleura2 
*          The number of columns of the matrix A.  N >= 0.
64 1 pfleura2 
*
65 1 pfleura2 
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
66 1 pfleura2 
*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
67 1 pfleura2 
*          storage type.
68 1 pfleura2 
*
69 1 pfleura2 
*  LDA     (input) INTEGER
70 1 pfleura2 
*          The leading dimension of the array A.  LDA >= max(1,M).
71 1 pfleura2 
*
72 1 pfleura2 
*  INFO    (output) INTEGER
73 1 pfleura2 
*          0  - successful exit
74 1 pfleura2 
*          <0 - if INFO = -i, the i-th argument had an illegal value.
75 1 pfleura2 
*
76 1 pfleura2 
*  =====================================================================
77 1 pfleura2 
*
78 1 pfleura2 
*     .. Parameters ..
79 1 pfleura2 
      DOUBLE PRECISION   ZERO, ONE
80 1 pfleura2 
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
81 1 pfleura2 
*     ..
82 1 pfleura2 
*     .. Local Scalars ..
83 1 pfleura2 
      LOGICAL            DONE
84 1 pfleura2 
      INTEGER            I, ITYPE, J, K1, K2, K3, K4
85 1 pfleura2 
      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
86 1 pfleura2 
*     ..
87 1 pfleura2 
*     .. External Functions ..
88 1 pfleura2 
      LOGICAL            LSAME, DISNAN
89 1 pfleura2 
      DOUBLE PRECISION   DLAMCH
90 1 pfleura2 
      EXTERNAL           LSAME, DLAMCH, DISNAN
91 1 pfleura2 
*     ..
92 1 pfleura2 
*     .. Intrinsic Functions ..
93 1 pfleura2 
      INTRINSIC          ABS, MAX, MIN
94 1 pfleura2 
*     ..
95 1 pfleura2 
*     .. External Subroutines ..
96 1 pfleura2 
      EXTERNAL           XERBLA
97 1 pfleura2 
*     ..
98 1 pfleura2 
*     .. Executable Statements ..
99 1 pfleura2 
*
100 1 pfleura2 
*     Test the input arguments
101 1 pfleura2 
*
102 1 pfleura2 
      INFO = 0
103 1 pfleura2 
*
104 1 pfleura2 
      IF( LSAME( TYPE, 'G' ) ) THEN
105 1 pfleura2 
         ITYPE = 0
106 1 pfleura2 
      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
107 1 pfleura2 
         ITYPE = 1
108 1 pfleura2 
      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
109 1 pfleura2 
         ITYPE = 2
110 1 pfleura2 
      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
111 1 pfleura2 
         ITYPE = 3
112 1 pfleura2 
      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
113 1 pfleura2 
         ITYPE = 4
114 1 pfleura2 
      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
115 1 pfleura2 
         ITYPE = 5
116 1 pfleura2 
      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
117 1 pfleura2 
         ITYPE = 6
118 1 pfleura2 
      ELSE
119 1 pfleura2 
         ITYPE = -1
120 1 pfleura2 
      END IF
121 1 pfleura2 
*
122 1 pfleura2 
      IF( ITYPE.EQ.-1 ) THEN
123 1 pfleura2 
         INFO = -1
124 1 pfleura2 
      ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
125 1 pfleura2 
         INFO = -4
126 1 pfleura2 
      ELSE IF( DISNAN(CTO) ) THEN
127 1 pfleura2 
         INFO = -5
128 1 pfleura2 
      ELSE IF( M.LT.0 ) THEN
129 1 pfleura2 
         INFO = -6
130 1 pfleura2 
      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
131 1 pfleura2 
     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
132 1 pfleura2 
         INFO = -7
133 1 pfleura2 
      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
134 1 pfleura2 
         INFO = -9
135 1 pfleura2 
      ELSE IF( ITYPE.GE.4 ) THEN
136 1 pfleura2 
         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
137 1 pfleura2 
            INFO = -2
138 1 pfleura2 
         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
139 1 pfleura2 
     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
140 1 pfleura2 
     $             THEN
141 1 pfleura2 
            INFO = -3
142 1 pfleura2 
         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
143 1 pfleura2 
     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
144 1 pfleura2 
     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
145 1 pfleura2 
            INFO = -9
146 1 pfleura2 
         END IF
147 1 pfleura2 
      END IF
148 1 pfleura2 
*
149 1 pfleura2 
      IF( INFO.NE.0 ) THEN
150 1 pfleura2 
         CALL XERBLA( 'DLASCL', -INFO )
151 1 pfleura2 
         RETURN
152 1 pfleura2 
      END IF
153 1 pfleura2 
*
154 1 pfleura2 
*     Quick return if possible
155 1 pfleura2 
*
156 1 pfleura2 
      IF( N.EQ.0 .OR. M.EQ.0 )
157 1 pfleura2 
     $   RETURN
158 1 pfleura2 
*
159 1 pfleura2 
*     Get machine parameters
160 1 pfleura2 
*
161 1 pfleura2 
      SMLNUM = DLAMCH( 'S' )
162 1 pfleura2 
      BIGNUM = ONE / SMLNUM
163 1 pfleura2 
*
164 1 pfleura2 
      CFROMC = CFROM
165 1 pfleura2 
      CTOC = CTO
166 1 pfleura2 
*
167 1 pfleura2 
   10 CONTINUE
168 1 pfleura2 
      CFROM1 = CFROMC*SMLNUM
169 1 pfleura2 
      IF( CFROM1.EQ.CFROMC ) THEN
170 1 pfleura2 
!        CFROMC is an inf.  Multiply by a correctly signed zero for
171 1 pfleura2 
!        finite CTOC, or a NaN if CTOC is infinite.
172 1 pfleura2 
         MUL = CTOC / CFROMC
173 1 pfleura2 
         DONE = .TRUE.
174 1 pfleura2 
         CTO1 = CTOC
175 1 pfleura2 
      ELSE
176 1 pfleura2 
         CTO1 = CTOC / BIGNUM
177 1 pfleura2 
         IF( CTO1.EQ.CTOC ) THEN
178 1 pfleura2 
!           CTOC is either 0 or an inf.  In both cases, CTOC itself
179 1 pfleura2 
!           serves as the correct multiplication factor.
180 1 pfleura2 
            MUL = CTOC
181 1 pfleura2 
            DONE = .TRUE.
182 1 pfleura2 
            CFROMC = ONE
183 1 pfleura2 
         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
184 1 pfleura2 
            MUL = SMLNUM
185 1 pfleura2 
            DONE = .FALSE.
186 1 pfleura2 
            CFROMC = CFROM1
187 1 pfleura2 
         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
188 1 pfleura2 
            MUL = BIGNUM
189 1 pfleura2 
            DONE = .FALSE.
190 1 pfleura2 
            CTOC = CTO1
191 1 pfleura2 
         ELSE
192 1 pfleura2 
            MUL = CTOC / CFROMC
193 1 pfleura2 
            DONE = .TRUE.
194 1 pfleura2 
         END IF
195 1 pfleura2 
      END IF
196 1 pfleura2 
*
197 1 pfleura2 
      IF( ITYPE.EQ.0 ) THEN
198 1 pfleura2 
*
199 1 pfleura2 
*        Full matrix
200 1 pfleura2 
*
201 1 pfleura2 
         DO 30 J = 1, N
202 1 pfleura2 
            DO 20 I = 1, M
203 1 pfleura2 
               A( I, J ) = A( I, J )*MUL
204 1 pfleura2 
   20       CONTINUE
205 1 pfleura2 
   30    CONTINUE
206 1 pfleura2 
*
207 1 pfleura2 
      ELSE IF( ITYPE.EQ.1 ) THEN
208 1 pfleura2 
*
209 1 pfleura2 
*        Lower triangular matrix
210 1 pfleura2 
*
211 1 pfleura2 
         DO 50 J = 1, N
212 1 pfleura2 
            DO 40 I = J, M
213 1 pfleura2 
               A( I, J ) = A( I, J )*MUL
214 1 pfleura2 
   40       CONTINUE
215 1 pfleura2 
   50    CONTINUE
216 1 pfleura2 
*
217 1 pfleura2 
      ELSE IF( ITYPE.EQ.2 ) THEN
218 1 pfleura2 
*
219 1 pfleura2 
*        Upper triangular matrix
220 1 pfleura2 
*
221 1 pfleura2 
         DO 70 J = 1, N
222 1 pfleura2 
            DO 60 I = 1, MIN( J, M )
223 1 pfleura2 
               A( I, J ) = A( I, J )*MUL
224 1 pfleura2 
   60       CONTINUE
225 1 pfleura2 
   70    CONTINUE
226 1 pfleura2 
*
227 1 pfleura2 
      ELSE IF( ITYPE.EQ.3 ) THEN
228 1 pfleura2 
*
229 1 pfleura2 
*        Upper Hessenberg matrix
230 1 pfleura2 
*
231 1 pfleura2 
         DO 90 J = 1, N
232 1 pfleura2 
            DO 80 I = 1, MIN( J+1, M )
233 1 pfleura2 
               A( I, J ) = A( I, J )*MUL
234 1 pfleura2 
   80       CONTINUE
235 1 pfleura2 
   90    CONTINUE
236 1 pfleura2 
*
237 1 pfleura2 
      ELSE IF( ITYPE.EQ.4 ) THEN
238 1 pfleura2 
*
239 1 pfleura2 
*        Lower half of a symmetric band matrix
240 1 pfleura2 
*
241 1 pfleura2 
         K3 = KL + 1
242 1 pfleura2 
         K4 = N + 1
243 1 pfleura2 
         DO 110 J = 1, N
244 1 pfleura2 
            DO 100 I = 1, MIN( K3, K4-J )
245 1 pfleura2 
               A( I, J ) = A( I, J )*MUL
246 1 pfleura2 
  100       CONTINUE
247 1 pfleura2 
  110    CONTINUE
248 1 pfleura2 
*
249 1 pfleura2 
      ELSE IF( ITYPE.EQ.5 ) THEN
250 1 pfleura2 
*
251 1 pfleura2 
*        Upper half of a symmetric band matrix
252 1 pfleura2 
*
253 1 pfleura2 
         K1 = KU + 2
254 1 pfleura2 
         K3 = KU + 1
255 1 pfleura2 
         DO 130 J = 1, N
256 1 pfleura2 
            DO 120 I = MAX( K1-J, 1 ), K3
257 1 pfleura2 
               A( I, J ) = A( I, J )*MUL
258 1 pfleura2 
  120       CONTINUE
259 1 pfleura2 
  130    CONTINUE
260 1 pfleura2 
*
261 1 pfleura2 
      ELSE IF( ITYPE.EQ.6 ) THEN
262 1 pfleura2 
*
263 1 pfleura2 
*        Band matrix
264 1 pfleura2 
*
265 1 pfleura2 
         K1 = KL + KU + 2
266 1 pfleura2 
         K2 = KL + 1
267 1 pfleura2 
         K3 = 2*KL + KU + 1
268 1 pfleura2 
         K4 = KL + KU + 1 + M
269 1 pfleura2 
         DO 150 J = 1, N
270 1 pfleura2 
            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
271 1 pfleura2 
               A( I, J ) = A( I, J )*MUL
272 1 pfleura2 
  140       CONTINUE
273 1 pfleura2 
  150    CONTINUE
274 1 pfleura2 
*
275 1 pfleura2 
      END IF
276 1 pfleura2 
*
277 1 pfleura2 
      IF( .NOT.DONE )
278 1 pfleura2 
     $   GO TO 10
279 1 pfleura2 
*
280 1 pfleura2 
      RETURN
281 1 pfleura2 
*
282 1 pfleura2 
*     End of DLASCL
283 1 pfleura2 
*
284 1 pfleura2 
      END