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