![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CLASCL 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download CLASCL + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clascl.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clascl.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clascl.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) 00022 * 00023 * .. Scalar Arguments .. 00024 * CHARACTER TYPE 00025 * INTEGER INFO, KL, KU, LDA, M, N 00026 * REAL CFROM, CTO 00027 * .. 00028 * .. Array Arguments .. 00029 * COMPLEX A( LDA, * ) 00030 * .. 00031 * 00032 * 00033 *> \par Purpose: 00034 * ============= 00035 *> 00036 *> \verbatim 00037 *> 00038 *> CLASCL multiplies the M by N complex matrix A by the real scalar 00039 *> CTO/CFROM. This is done without over/underflow as long as the final 00040 *> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that 00041 *> A may be full, upper triangular, lower triangular, upper Hessenberg, 00042 *> or banded. 00043 *> \endverbatim 00044 * 00045 * Arguments: 00046 * ========== 00047 * 00048 *> \param[in] TYPE 00049 *> \verbatim 00050 *> TYPE is CHARACTER*1 00051 *> TYPE indices the storage type of the input matrix. 00052 *> = 'G': A is a full matrix. 00053 *> = 'L': A is a lower triangular matrix. 00054 *> = 'U': A is an upper triangular matrix. 00055 *> = 'H': A is an upper Hessenberg matrix. 00056 *> = 'B': A is a symmetric band matrix with lower bandwidth KL 00057 *> and upper bandwidth KU and with the only the lower 00058 *> half stored. 00059 *> = 'Q': A is a symmetric band matrix with lower bandwidth KL 00060 *> and upper bandwidth KU and with the only the upper 00061 *> half stored. 00062 *> = 'Z': A is a band matrix with lower bandwidth KL and upper 00063 *> bandwidth KU. See CGBTRF for storage details. 00064 *> \endverbatim 00065 *> 00066 *> \param[in] KL 00067 *> \verbatim 00068 *> KL is INTEGER 00069 *> The lower bandwidth of A. Referenced only if TYPE = 'B', 00070 *> 'Q' or 'Z'. 00071 *> \endverbatim 00072 *> 00073 *> \param[in] KU 00074 *> \verbatim 00075 *> KU is INTEGER 00076 *> The upper bandwidth of A. Referenced only if TYPE = 'B', 00077 *> 'Q' or 'Z'. 00078 *> \endverbatim 00079 *> 00080 *> \param[in] CFROM 00081 *> \verbatim 00082 *> CFROM is REAL 00083 *> \endverbatim 00084 *> 00085 *> \param[in] CTO 00086 *> \verbatim 00087 *> CTO is REAL 00088 *> 00089 *> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed 00090 *> without over/underflow if the final result CTO*A(I,J)/CFROM 00091 *> can be represented without over/underflow. CFROM must be 00092 *> nonzero. 00093 *> \endverbatim 00094 *> 00095 *> \param[in] M 00096 *> \verbatim 00097 *> M is INTEGER 00098 *> The number of rows of the matrix A. M >= 0. 00099 *> \endverbatim 00100 *> 00101 *> \param[in] N 00102 *> \verbatim 00103 *> N is INTEGER 00104 *> The number of columns of the matrix A. N >= 0. 00105 *> \endverbatim 00106 *> 00107 *> \param[in,out] A 00108 *> \verbatim 00109 *> A is COMPLEX array, dimension (LDA,N) 00110 *> The matrix to be multiplied by CTO/CFROM. See TYPE for the 00111 *> storage type. 00112 *> \endverbatim 00113 *> 00114 *> \param[in] LDA 00115 *> \verbatim 00116 *> LDA is INTEGER 00117 *> The leading dimension of the array A. LDA >= max(1,M). 00118 *> \endverbatim 00119 *> 00120 *> \param[out] INFO 00121 *> \verbatim 00122 *> INFO is INTEGER 00123 *> 0 - successful exit 00124 *> <0 - if INFO = -i, the i-th argument had an illegal value. 00125 *> \endverbatim 00126 * 00127 * Authors: 00128 * ======== 00129 * 00130 *> \author Univ. of Tennessee 00131 *> \author Univ. of California Berkeley 00132 *> \author Univ. of Colorado Denver 00133 *> \author NAG Ltd. 00134 * 00135 *> \date November 2011 00136 * 00137 *> \ingroup complexOTHERauxiliary 00138 * 00139 * ===================================================================== 00140 SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) 00141 * 00142 * -- LAPACK auxiliary routine (version 3.4.0) -- 00143 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00144 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00145 * November 2011 00146 * 00147 * .. Scalar Arguments .. 00148 CHARACTER TYPE 00149 INTEGER INFO, KL, KU, LDA, M, N 00150 REAL CFROM, CTO 00151 * .. 00152 * .. Array Arguments .. 00153 COMPLEX A( LDA, * ) 00154 * .. 00155 * 00156 * ===================================================================== 00157 * 00158 * .. Parameters .. 00159 REAL ZERO, ONE 00160 PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) 00161 * .. 00162 * .. Local Scalars .. 00163 LOGICAL DONE 00164 INTEGER I, ITYPE, J, K1, K2, K3, K4 00165 REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM 00166 * .. 00167 * .. External Functions .. 00168 LOGICAL LSAME, SISNAN 00169 REAL SLAMCH 00170 EXTERNAL LSAME, SLAMCH, SISNAN 00171 * .. 00172 * .. Intrinsic Functions .. 00173 INTRINSIC ABS, MAX, MIN 00174 * .. 00175 * .. External Subroutines .. 00176 EXTERNAL XERBLA 00177 * .. 00178 * .. Executable Statements .. 00179 * 00180 * Test the input arguments 00181 * 00182 INFO = 0 00183 * 00184 IF( LSAME( TYPE, 'G' ) ) THEN 00185 ITYPE = 0 00186 ELSE IF( LSAME( TYPE, 'L' ) ) THEN 00187 ITYPE = 1 00188 ELSE IF( LSAME( TYPE, 'U' ) ) THEN 00189 ITYPE = 2 00190 ELSE IF( LSAME( TYPE, 'H' ) ) THEN 00191 ITYPE = 3 00192 ELSE IF( LSAME( TYPE, 'B' ) ) THEN 00193 ITYPE = 4 00194 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN 00195 ITYPE = 5 00196 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN 00197 ITYPE = 6 00198 ELSE 00199 ITYPE = -1 00200 END IF 00201 * 00202 IF( ITYPE.EQ.-1 ) THEN 00203 INFO = -1 00204 ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN 00205 INFO = -4 00206 ELSE IF( SISNAN(CTO) ) THEN 00207 INFO = -5 00208 ELSE IF( M.LT.0 ) THEN 00209 INFO = -6 00210 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. 00211 $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN 00212 INFO = -7 00213 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN 00214 INFO = -9 00215 ELSE IF( ITYPE.GE.4 ) THEN 00216 IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN 00217 INFO = -2 00218 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. 00219 $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) 00220 $ THEN 00221 INFO = -3 00222 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. 00223 $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. 00224 $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN 00225 INFO = -9 00226 END IF 00227 END IF 00228 * 00229 IF( INFO.NE.0 ) THEN 00230 CALL XERBLA( 'CLASCL', -INFO ) 00231 RETURN 00232 END IF 00233 * 00234 * Quick return if possible 00235 * 00236 IF( N.EQ.0 .OR. M.EQ.0 ) 00237 $ RETURN 00238 * 00239 * Get machine parameters 00240 * 00241 SMLNUM = SLAMCH( 'S' ) 00242 BIGNUM = ONE / SMLNUM 00243 * 00244 CFROMC = CFROM 00245 CTOC = CTO 00246 * 00247 10 CONTINUE 00248 CFROM1 = CFROMC*SMLNUM 00249 IF( CFROM1.EQ.CFROMC ) THEN 00250 ! CFROMC is an inf. Multiply by a correctly signed zero for 00251 ! finite CTOC, or a NaN if CTOC is infinite. 00252 MUL = CTOC / CFROMC 00253 DONE = .TRUE. 00254 CTO1 = CTOC 00255 ELSE 00256 CTO1 = CTOC / BIGNUM 00257 IF( CTO1.EQ.CTOC ) THEN 00258 ! CTOC is either 0 or an inf. In both cases, CTOC itself 00259 ! serves as the correct multiplication factor. 00260 MUL = CTOC 00261 DONE = .TRUE. 00262 CFROMC = ONE 00263 ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN 00264 MUL = SMLNUM 00265 DONE = .FALSE. 00266 CFROMC = CFROM1 00267 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN 00268 MUL = BIGNUM 00269 DONE = .FALSE. 00270 CTOC = CTO1 00271 ELSE 00272 MUL = CTOC / CFROMC 00273 DONE = .TRUE. 00274 END IF 00275 END IF 00276 * 00277 IF( ITYPE.EQ.0 ) THEN 00278 * 00279 * Full matrix 00280 * 00281 DO 30 J = 1, N 00282 DO 20 I = 1, M 00283 A( I, J ) = A( I, J )*MUL 00284 20 CONTINUE 00285 30 CONTINUE 00286 * 00287 ELSE IF( ITYPE.EQ.1 ) THEN 00288 * 00289 * Lower triangular matrix 00290 * 00291 DO 50 J = 1, N 00292 DO 40 I = J, M 00293 A( I, J ) = A( I, J )*MUL 00294 40 CONTINUE 00295 50 CONTINUE 00296 * 00297 ELSE IF( ITYPE.EQ.2 ) THEN 00298 * 00299 * Upper triangular matrix 00300 * 00301 DO 70 J = 1, N 00302 DO 60 I = 1, MIN( J, M ) 00303 A( I, J ) = A( I, J )*MUL 00304 60 CONTINUE 00305 70 CONTINUE 00306 * 00307 ELSE IF( ITYPE.EQ.3 ) THEN 00308 * 00309 * Upper Hessenberg matrix 00310 * 00311 DO 90 J = 1, N 00312 DO 80 I = 1, MIN( J+1, M ) 00313 A( I, J ) = A( I, J )*MUL 00314 80 CONTINUE 00315 90 CONTINUE 00316 * 00317 ELSE IF( ITYPE.EQ.4 ) THEN 00318 * 00319 * Lower half of a symmetric band matrix 00320 * 00321 K3 = KL + 1 00322 K4 = N + 1 00323 DO 110 J = 1, N 00324 DO 100 I = 1, MIN( K3, K4-J ) 00325 A( I, J ) = A( I, J )*MUL 00326 100 CONTINUE 00327 110 CONTINUE 00328 * 00329 ELSE IF( ITYPE.EQ.5 ) THEN 00330 * 00331 * Upper half of a symmetric band matrix 00332 * 00333 K1 = KU + 2 00334 K3 = KU + 1 00335 DO 130 J = 1, N 00336 DO 120 I = MAX( K1-J, 1 ), K3 00337 A( I, J ) = A( I, J )*MUL 00338 120 CONTINUE 00339 130 CONTINUE 00340 * 00341 ELSE IF( ITYPE.EQ.6 ) THEN 00342 * 00343 * Band matrix 00344 * 00345 K1 = KL + KU + 2 00346 K2 = KL + 1 00347 K3 = 2*KL + KU + 1 00348 K4 = KL + KU + 1 + M 00349 DO 150 J = 1, N 00350 DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) 00351 A( I, J ) = A( I, J )*MUL 00352 140 CONTINUE 00353 150 CONTINUE 00354 * 00355 END IF 00356 * 00357 IF( .NOT.DONE ) 00358 $ GO TO 10 00359 * 00360 RETURN 00361 * 00362 * End of CLASCL 00363 * 00364 END