Annotation of rpl/lapack/lapack/zlascl.f, revision 1.1
1.1 ! bertrand 1: SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
! 2: *
! 3: * -- LAPACK auxiliary routine (version 3.2) --
! 4: * -- LAPACK is a software package provided by Univ. of Tennessee, --
! 5: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! 6: * November 2006
! 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: COMPLEX*16 A( LDA, * )
! 15: * ..
! 16: *
! 17: * Purpose
! 18: * =======
! 19: *
! 20: * ZLASCL multiplies the M by N complex 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) COMPLEX*16 array, dimension (LDA,N)
! 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, DISNAN
! 89: DOUBLE PRECISION DLAMCH
! 90: EXTERNAL LSAME, DLAMCH, DISNAN
! 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 .OR. DISNAN(CFROM) ) THEN
! 125: INFO = -4
! 126: ELSE IF( DISNAN(CTO) ) THEN
! 127: INFO = -5
! 128: ELSE IF( M.LT.0 ) THEN
! 129: INFO = -6
! 130: ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
! 131: $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
! 132: INFO = -7
! 133: ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
! 134: INFO = -9
! 135: ELSE IF( ITYPE.GE.4 ) THEN
! 136: IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
! 137: INFO = -2
! 138: ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
! 139: $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
! 140: $ THEN
! 141: INFO = -3
! 142: ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
! 143: $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
! 144: $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
! 145: INFO = -9
! 146: END IF
! 147: END IF
! 148: *
! 149: IF( INFO.NE.0 ) THEN
! 150: CALL XERBLA( 'ZLASCL', -INFO )
! 151: RETURN
! 152: END IF
! 153: *
! 154: * Quick return if possible
! 155: *
! 156: IF( N.EQ.0 .OR. M.EQ.0 )
! 157: $ RETURN
! 158: *
! 159: * Get machine parameters
! 160: *
! 161: SMLNUM = DLAMCH( 'S' )
! 162: BIGNUM = ONE / SMLNUM
! 163: *
! 164: CFROMC = CFROM
! 165: CTOC = CTO
! 166: *
! 167: 10 CONTINUE
! 168: CFROM1 = CFROMC*SMLNUM
! 169: IF( CFROM1.EQ.CFROMC ) THEN
! 170: ! CFROMC is an inf. Multiply by a correctly signed zero for
! 171: ! finite CTOC, or a NaN if CTOC is infinite.
! 172: MUL = CTOC / CFROMC
! 173: DONE = .TRUE.
! 174: CTO1 = CTOC
! 175: ELSE
! 176: CTO1 = CTOC / BIGNUM
! 177: IF( CTO1.EQ.CTOC ) THEN
! 178: ! CTOC is either 0 or an inf. In both cases, CTOC itself
! 179: ! serves as the correct multiplication factor.
! 180: MUL = CTOC
! 181: DONE = .TRUE.
! 182: CFROMC = ONE
! 183: ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
! 184: MUL = SMLNUM
! 185: DONE = .FALSE.
! 186: CFROMC = CFROM1
! 187: ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
! 188: MUL = BIGNUM
! 189: DONE = .FALSE.
! 190: CTOC = CTO1
! 191: ELSE
! 192: MUL = CTOC / CFROMC
! 193: DONE = .TRUE.
! 194: END IF
! 195: END IF
! 196: *
! 197: IF( ITYPE.EQ.0 ) THEN
! 198: *
! 199: * Full matrix
! 200: *
! 201: DO 30 J = 1, N
! 202: DO 20 I = 1, M
! 203: A( I, J ) = A( I, J )*MUL
! 204: 20 CONTINUE
! 205: 30 CONTINUE
! 206: *
! 207: ELSE IF( ITYPE.EQ.1 ) THEN
! 208: *
! 209: * Lower triangular matrix
! 210: *
! 211: DO 50 J = 1, N
! 212: DO 40 I = J, M
! 213: A( I, J ) = A( I, J )*MUL
! 214: 40 CONTINUE
! 215: 50 CONTINUE
! 216: *
! 217: ELSE IF( ITYPE.EQ.2 ) THEN
! 218: *
! 219: * Upper triangular matrix
! 220: *
! 221: DO 70 J = 1, N
! 222: DO 60 I = 1, MIN( J, M )
! 223: A( I, J ) = A( I, J )*MUL
! 224: 60 CONTINUE
! 225: 70 CONTINUE
! 226: *
! 227: ELSE IF( ITYPE.EQ.3 ) THEN
! 228: *
! 229: * Upper Hessenberg matrix
! 230: *
! 231: DO 90 J = 1, N
! 232: DO 80 I = 1, MIN( J+1, M )
! 233: A( I, J ) = A( I, J )*MUL
! 234: 80 CONTINUE
! 235: 90 CONTINUE
! 236: *
! 237: ELSE IF( ITYPE.EQ.4 ) THEN
! 238: *
! 239: * Lower half of a symmetric band matrix
! 240: *
! 241: K3 = KL + 1
! 242: K4 = N + 1
! 243: DO 110 J = 1, N
! 244: DO 100 I = 1, MIN( K3, K4-J )
! 245: A( I, J ) = A( I, J )*MUL
! 246: 100 CONTINUE
! 247: 110 CONTINUE
! 248: *
! 249: ELSE IF( ITYPE.EQ.5 ) THEN
! 250: *
! 251: * Upper half of a symmetric band matrix
! 252: *
! 253: K1 = KU + 2
! 254: K3 = KU + 1
! 255: DO 130 J = 1, N
! 256: DO 120 I = MAX( K1-J, 1 ), K3
! 257: A( I, J ) = A( I, J )*MUL
! 258: 120 CONTINUE
! 259: 130 CONTINUE
! 260: *
! 261: ELSE IF( ITYPE.EQ.6 ) THEN
! 262: *
! 263: * Band matrix
! 264: *
! 265: K1 = KL + KU + 2
! 266: K2 = KL + 1
! 267: K3 = 2*KL + KU + 1
! 268: K4 = KL + KU + 1 + M
! 269: DO 150 J = 1, N
! 270: DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
! 271: A( I, J ) = A( I, J )*MUL
! 272: 140 CONTINUE
! 273: 150 CONTINUE
! 274: *
! 275: END IF
! 276: *
! 277: IF( .NOT.DONE )
! 278: $ GO TO 10
! 279: *
! 280: RETURN
! 281: *
! 282: * End of ZLASCL
! 283: *
! 284: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zlascl.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack