335 lines
9.4 KiB
Fortran
335 lines
9.4 KiB
Fortran
SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A,
|
|
$ LDA, INFO )
|
|
C
|
|
C SLICOT RELEASE 5.0.
|
|
C
|
|
C Copyright (c) 2002-2009 NICONET e.V.
|
|
C
|
|
C This program is free software: you can redistribute it and/or
|
|
C modify it under the terms of the GNU General Public License as
|
|
C published by the Free Software Foundation, either version 2 of
|
|
C the License, or (at your option) any later version.
|
|
C
|
|
C This program is distributed in the hope that it will be useful,
|
|
C but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
C GNU General Public License for more details.
|
|
C
|
|
C You should have received a copy of the GNU General Public License
|
|
C along with this program. If not, see
|
|
C <http://www.gnu.org/licenses/>.
|
|
C
|
|
C PURPOSE
|
|
C
|
|
C To multiply the M by N real matrix A by the real scalar CTO/CFROM.
|
|
C This is done without over/underflow as long as the final result
|
|
C CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
|
|
C A may be full, (block) upper triangular, (block) lower triangular,
|
|
C (block) upper Hessenberg, or banded.
|
|
C
|
|
C ARGUMENTS
|
|
C
|
|
C Mode Parameters
|
|
C
|
|
C TYPE CHARACTER*1
|
|
C TYPE indices the storage type of the input matrix.
|
|
C = 'G': A is a full matrix.
|
|
C = 'L': A is a (block) lower triangular matrix.
|
|
C = 'U': A is a (block) upper triangular matrix.
|
|
C = 'H': A is a (block) upper Hessenberg matrix.
|
|
C = 'B': A is a symmetric band matrix with lower bandwidth
|
|
C KL and upper bandwidth KU and with the only the
|
|
C lower half stored.
|
|
C = 'Q': A is a symmetric band matrix with lower bandwidth
|
|
C KL and upper bandwidth KU and with the only the
|
|
C upper half stored.
|
|
C = 'Z': A is a band matrix with lower bandwidth KL and
|
|
C upper bandwidth KU.
|
|
C
|
|
C Input/Output Parameters
|
|
C
|
|
C M (input) INTEGER
|
|
C The number of rows of the matrix A. M >= 0.
|
|
C
|
|
C N (input) INTEGER
|
|
C The number of columns of the matrix A. N >= 0.
|
|
C
|
|
C KL (input) INTEGER
|
|
C The lower bandwidth of A. Referenced only if TYPE = 'B',
|
|
C 'Q' or 'Z'.
|
|
C
|
|
C KU (input) INTEGER
|
|
C The upper bandwidth of A. Referenced only if TYPE = 'B',
|
|
C 'Q' or 'Z'.
|
|
C
|
|
C CFROM (input) DOUBLE PRECISION
|
|
C CTO (input) DOUBLE PRECISION
|
|
C The matrix A is multiplied by CTO/CFROM. A(I,J) is
|
|
C computed without over/underflow if the final result
|
|
C CTO*A(I,J)/CFROM can be represented without over/
|
|
C underflow. CFROM must be nonzero.
|
|
C
|
|
C NBL (input) INTEGER
|
|
C The number of diagonal blocks of the matrix A, if it has a
|
|
C block structure. To specify that matrix A has no block
|
|
C structure, set NBL = 0. NBL >= 0.
|
|
C
|
|
C NROWS (input) INTEGER array, dimension max(1,NBL)
|
|
C NROWS(i) contains the number of rows and columns of the
|
|
C i-th diagonal block of matrix A. The sum of the values
|
|
C NROWS(i), for i = 1: NBL, should be equal to min(M,N).
|
|
C The array NROWS is not referenced if NBL = 0.
|
|
C
|
|
C A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
|
|
C The matrix to be multiplied by CTO/CFROM. See TYPE for
|
|
C the storage type.
|
|
C
|
|
C LDA (input) INTEGER
|
|
C The leading dimension of the array A. LDA >= max(1,M).
|
|
C
|
|
C Error Indicator
|
|
C
|
|
C INFO INTEGER
|
|
C Not used in this implementation.
|
|
C
|
|
C METHOD
|
|
C
|
|
C Matrix A is multiplied by the real scalar CTO/CFROM, taking into
|
|
C account the specified storage mode of the matrix.
|
|
C MB01QD is a version of the LAPACK routine DLASCL, modified for
|
|
C dealing with block triangular, or block Hessenberg matrices.
|
|
C For efficiency, no tests of the input scalar parameters are
|
|
C performed.
|
|
C
|
|
C CONTRIBUTOR
|
|
C
|
|
C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996.
|
|
C
|
|
C ******************************************************************
|
|
C
|
|
C .. Parameters ..
|
|
DOUBLE PRECISION ZERO, ONE
|
|
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
|
|
C ..
|
|
C .. Scalar Arguments ..
|
|
CHARACTER TYPE
|
|
INTEGER INFO, KL, KU, LDA, M, N, NBL
|
|
DOUBLE PRECISION CFROM, CTO
|
|
C ..
|
|
C .. Array Arguments ..
|
|
INTEGER NROWS ( * )
|
|
DOUBLE PRECISION A( LDA, * )
|
|
C ..
|
|
C .. Local Scalars ..
|
|
LOGICAL DONE, NOBLC
|
|
INTEGER I, IFIN, ITYPE, J, JFIN, JINI, K, K1, K2, K3,
|
|
$ K4
|
|
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
|
|
C ..
|
|
C .. External Functions ..
|
|
LOGICAL LSAME
|
|
DOUBLE PRECISION DLAMCH
|
|
EXTERNAL LSAME, DLAMCH
|
|
C ..
|
|
C .. Intrinsic Functions ..
|
|
INTRINSIC ABS, MAX, MIN
|
|
C ..
|
|
C .. Executable Statements ..
|
|
C
|
|
IF( LSAME( TYPE, 'G' ) ) THEN
|
|
ITYPE = 0
|
|
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
|
|
ITYPE = 1
|
|
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
|
|
ITYPE = 2
|
|
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
|
|
ITYPE = 3
|
|
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
|
|
ITYPE = 4
|
|
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
|
|
ITYPE = 5
|
|
ELSE
|
|
ITYPE = 6
|
|
END IF
|
|
C
|
|
C Quick return if possible.
|
|
C
|
|
IF( MIN( M, N ).EQ.0 )
|
|
$ RETURN
|
|
C
|
|
C Get machine parameters.
|
|
C
|
|
SMLNUM = DLAMCH( 'S' )
|
|
BIGNUM = ONE / SMLNUM
|
|
C
|
|
CFROMC = CFROM
|
|
CTOC = CTO
|
|
C
|
|
10 CONTINUE
|
|
CFROM1 = CFROMC*SMLNUM
|
|
CTO1 = CTOC / BIGNUM
|
|
IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
|
|
MUL = SMLNUM
|
|
DONE = .FALSE.
|
|
CFROMC = CFROM1
|
|
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
|
|
MUL = BIGNUM
|
|
DONE = .FALSE.
|
|
CTOC = CTO1
|
|
ELSE
|
|
MUL = CTOC / CFROMC
|
|
DONE = .TRUE.
|
|
END IF
|
|
C
|
|
NOBLC = NBL.EQ.0
|
|
C
|
|
IF( ITYPE.EQ.0 ) THEN
|
|
C
|
|
C Full matrix
|
|
C
|
|
DO 30 J = 1, N
|
|
DO 20 I = 1, M
|
|
A( I, J ) = A( I, J )*MUL
|
|
20 CONTINUE
|
|
30 CONTINUE
|
|
C
|
|
ELSE IF( ITYPE.EQ.1 ) THEN
|
|
C
|
|
IF ( NOBLC ) THEN
|
|
C
|
|
C Lower triangular matrix
|
|
C
|
|
DO 50 J = 1, N
|
|
DO 40 I = J, M
|
|
A( I, J ) = A( I, J )*MUL
|
|
40 CONTINUE
|
|
50 CONTINUE
|
|
C
|
|
ELSE
|
|
C
|
|
C Block lower triangular matrix
|
|
C
|
|
JFIN = 0
|
|
DO 80 K = 1, NBL
|
|
JINI = JFIN + 1
|
|
JFIN = JFIN + NROWS( K )
|
|
DO 70 J = JINI, JFIN
|
|
DO 60 I = JINI, M
|
|
A( I, J ) = A( I, J )*MUL
|
|
60 CONTINUE
|
|
70 CONTINUE
|
|
80 CONTINUE
|
|
END IF
|
|
C
|
|
ELSE IF( ITYPE.EQ.2 ) THEN
|
|
C
|
|
IF ( NOBLC ) THEN
|
|
C
|
|
C Upper triangular matrix
|
|
C
|
|
DO 100 J = 1, N
|
|
DO 90 I = 1, MIN( J, M )
|
|
A( I, J ) = A( I, J )*MUL
|
|
90 CONTINUE
|
|
100 CONTINUE
|
|
C
|
|
ELSE
|
|
C
|
|
C Block upper triangular matrix
|
|
C
|
|
JFIN = 0
|
|
DO 130 K = 1, NBL
|
|
JINI = JFIN + 1
|
|
JFIN = JFIN + NROWS( K )
|
|
IF ( K.EQ.NBL ) JFIN = N
|
|
DO 120 J = JINI, JFIN
|
|
DO 110 I = 1, MIN( JFIN, M )
|
|
A( I, J ) = A( I, J )*MUL
|
|
110 CONTINUE
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
END IF
|
|
C
|
|
ELSE IF( ITYPE.EQ.3 ) THEN
|
|
C
|
|
IF ( NOBLC ) THEN
|
|
C
|
|
C Upper Hessenberg matrix
|
|
C
|
|
DO 150 J = 1, N
|
|
DO 140 I = 1, MIN( J+1, M )
|
|
A( I, J ) = A( I, J )*MUL
|
|
140 CONTINUE
|
|
150 CONTINUE
|
|
C
|
|
ELSE
|
|
C
|
|
C Block upper Hessenberg matrix
|
|
C
|
|
JFIN = 0
|
|
DO 180 K = 1, NBL
|
|
JINI = JFIN + 1
|
|
JFIN = JFIN + NROWS( K )
|
|
C
|
|
IF ( K.EQ.NBL ) THEN
|
|
JFIN = N
|
|
IFIN = N
|
|
ELSE
|
|
IFIN = JFIN + NROWS( K+1 )
|
|
END IF
|
|
C
|
|
DO 170 J = JINI, JFIN
|
|
DO 160 I = 1, MIN( IFIN, M )
|
|
A( I, J ) = A( I, J )*MUL
|
|
160 CONTINUE
|
|
170 CONTINUE
|
|
180 CONTINUE
|
|
END IF
|
|
C
|
|
ELSE IF( ITYPE.EQ.4 ) THEN
|
|
C
|
|
C Lower half of a symmetric band matrix
|
|
C
|
|
K3 = KL + 1
|
|
K4 = N + 1
|
|
DO 200 J = 1, N
|
|
DO 190 I = 1, MIN( K3, K4-J )
|
|
A( I, J ) = A( I, J )*MUL
|
|
190 CONTINUE
|
|
200 CONTINUE
|
|
C
|
|
ELSE IF( ITYPE.EQ.5 ) THEN
|
|
C
|
|
C Upper half of a symmetric band matrix
|
|
C
|
|
K1 = KU + 2
|
|
K3 = KU + 1
|
|
DO 220 J = 1, N
|
|
DO 210 I = MAX( K1-J, 1 ), K3
|
|
A( I, J ) = A( I, J )*MUL
|
|
210 CONTINUE
|
|
220 CONTINUE
|
|
C
|
|
ELSE IF( ITYPE.EQ.6 ) THEN
|
|
C
|
|
C Band matrix
|
|
C
|
|
K1 = KL + KU + 2
|
|
K2 = KL + 1
|
|
K3 = 2*KL + KU + 1
|
|
K4 = KL + KU + 1 + M
|
|
DO 240 J = 1, N
|
|
DO 230 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
|
|
A( I, J ) = A( I, J )*MUL
|
|
230 CONTINUE
|
|
240 CONTINUE
|
|
C
|
|
END IF
|
|
C
|
|
IF( .NOT.DONE )
|
|
$ GO TO 10
|
|
C
|
|
RETURN
|
|
C *** Last line of MB01QD ***
|
|
END
|