stepan
/
dynare
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
dynare/mex/sources/libslicot/MB04NY.f

438 lines
12 KiB
Fortran
Raw Blame History

SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK )
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 apply a real elementary reflector H to a real m-by-(n+1)
C matrix C = [ A B ], from the right, where A has one column. H is
C represented in the form
C ( 1 )
C H = I - tau * u *u', u = ( ),
C ( v )
C where tau is a real scalar and v is a real n-vector.
C
C If tau = 0, then H is taken to be the unit matrix.
C
C In-line code is used if H has order < 11.
C
C ARGUMENTS
C
C Input/Output Parameters
C
C M (input) INTEGER
C The number of rows of the matrices A and B. M >= 0.
C
C N (input) INTEGER
C The number of columns of the matrix B. N >= 0.
C
C V (input) DOUBLE PRECISION array, dimension
C (1+(N-1)*ABS( INCV ))
C The vector v in the representation of H.
C
C INCV (input) INTEGER
C The increment between the elements of v. INCV <> 0.
C
C TAU (input) DOUBLE PRECISION
C The scalar factor of the elementary reflector H.
C
C A (input/output) DOUBLE PRECISION array, dimension (LDA,1)
C On entry, the leading M-by-1 part of this array must
C contain the matrix A.
C On exit, the leading M-by-1 part of this array contains
C the updated matrix A (the first column of C * H).
C
C LDA INTEGER
C The leading dimension of array A. LDA >= MAX(1,M).
C
C B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C On entry, the leading M-by-N part of this array must
C contain the matrix B.
C On exit, the leading M-by-N part of this array contains
C the updated matrix B (the last n columns of C * H).
C
C LDB INTEGER
C The leading dimension of array B. LDB >= MAX(1,M).
C
C Workspace
C
C DWORK DOUBLE PRECISION array, dimension (M)
C DWORK is not referenced if H has order less than 11.
C
C METHOD
C
C The routine applies the elementary reflector H, taking the special
C structure of C into account.
C
C NUMERICAL ASPECTS
C
C The algorithm is backward stable.
C
C CONTRIBUTORS
C
C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998.
C Based on LAPACK routines DLARFX and DLATZM.
C
C REVISIONS
C
C -
C
C KEYWORDS
C
C Elementary matrix operations, elementary reflector, orthogonal
C transformation.
C
C ******************************************************************
C
C .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
C .. Scalar Arguments ..
INTEGER INCV, LDA, LDB, M, N
DOUBLE PRECISION TAU
C .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * )
C .. Local Scalars ..
INTEGER IV, J
DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2,
$ V3, V4, V5, V6, V7, V8, V9
C .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMV, DGER
C
C .. Executable Statements ..
C
IF( TAU.EQ.ZERO )
$ RETURN
C
C Form C * H, where H has order n+1.
C
GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
$ 170, 190 ) N+1
C
C Code for general N. Compute
C
C w := C*u, C := C - tau * w * u'.
C
CALL DCOPY( M, A, 1, DWORK, 1 )
CALL DGEMV( 'No transpose', M, N, ONE, B, LDB, V, INCV, ONE,
$ DWORK, 1 )
CALL DAXPY( M, -TAU, DWORK, 1, A, 1 )
CALL DGER( M, N, -TAU, DWORK, 1, V, INCV, B, LDB )
GO TO 210
10 CONTINUE
C
C Special code for 1 x 1 Householder
C
T1 = ONE - TAU
DO 20 J = 1, M
A( J, 1 ) = T1*A( J, 1 )
20 CONTINUE
GO TO 210
30 CONTINUE
C
C Special code for 2 x 2 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
DO 40 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
40 CONTINUE
GO TO 210
50 CONTINUE
C
C Special code for 3 x 3 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
IV = IV + INCV
V2 = V( IV )
T2 = TAU*V2
DO 60 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
B( J, 2 ) = B( J, 2 ) - SUM*T2
60 CONTINUE
GO TO 210
70 CONTINUE
C
C Special code for 4 x 4 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
IV = IV + INCV
V2 = V( IV )
T2 = TAU*V2
IV = IV + INCV
V3 = V( IV )
T3 = TAU*V3
DO 80 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
B( J, 2 ) = B( J, 2 ) - SUM*T2
B( J, 3 ) = B( J, 3 ) - SUM*T3
80 CONTINUE
GO TO 210
90 CONTINUE
C
C Special code for 5 x 5 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
IV = IV + INCV
V2 = V( IV )
T2 = TAU*V2
IV = IV + INCV
V3 = V( IV )
T3 = TAU*V3
IV = IV + INCV
V4 = V( IV )
T4 = TAU*V4
DO 100 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
$ V4*B( J, 4 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
B( J, 2 ) = B( J, 2 ) - SUM*T2
B( J, 3 ) = B( J, 3 ) - SUM*T3
B( J, 4 ) = B( J, 4 ) - SUM*T4
100 CONTINUE
GO TO 210
110 CONTINUE
C
C Special code for 6 x 6 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
IV = IV + INCV
V2 = V( IV )
T2 = TAU*V2
IV = IV + INCV
V3 = V( IV )
T3 = TAU*V3
IV = IV + INCV
V4 = V( IV )
T4 = TAU*V4
IV = IV + INCV
V5 = V( IV )
T5 = TAU*V5
DO 120 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
$ V4*B( J, 4 ) + V5*B( J, 5 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
B( J, 2 ) = B( J, 2 ) - SUM*T2
B( J, 3 ) = B( J, 3 ) - SUM*T3
B( J, 4 ) = B( J, 4 ) - SUM*T4
B( J, 5 ) = B( J, 5 ) - SUM*T5
120 CONTINUE
GO TO 210
130 CONTINUE
C
C Special code for 7 x 7 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
IV = IV + INCV
V2 = V( IV )
T2 = TAU*V2
IV = IV + INCV
V3 = V( IV )
T3 = TAU*V3
IV = IV + INCV
V4 = V( IV )
T4 = TAU*V4
IV = IV + INCV
V5 = V( IV )
T5 = TAU*V5
IV = IV + INCV
V6 = V( IV )
T6 = TAU*V6
DO 140 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
$ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
B( J, 2 ) = B( J, 2 ) - SUM*T2
B( J, 3 ) = B( J, 3 ) - SUM*T3
B( J, 4 ) = B( J, 4 ) - SUM*T4
B( J, 5 ) = B( J, 5 ) - SUM*T5
B( J, 6 ) = B( J, 6 ) - SUM*T6
140 CONTINUE
GO TO 210
150 CONTINUE
C
C Special code for 8 x 8 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
IV = IV + INCV
V2 = V( IV )
T2 = TAU*V2
IV = IV + INCV
V3 = V( IV )
T3 = TAU*V3
IV = IV + INCV
V4 = V( IV )
T4 = TAU*V4
IV = IV + INCV
V5 = V( IV )
T5 = TAU*V5
IV = IV + INCV
V6 = V( IV )
T6 = TAU*V6
IV = IV + INCV
V7 = V( IV )
T7 = TAU*V7
DO 160 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
$ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) +
$ V7*B( J, 7 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
B( J, 2 ) = B( J, 2 ) - SUM*T2
B( J, 3 ) = B( J, 3 ) - SUM*T3
B( J, 4 ) = B( J, 4 ) - SUM*T4
B( J, 5 ) = B( J, 5 ) - SUM*T5
B( J, 6 ) = B( J, 6 ) - SUM*T6
B( J, 7 ) = B( J, 7 ) - SUM*T7
160 CONTINUE
GO TO 210
170 CONTINUE
C
C Special code for 9 x 9 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
IV = IV + INCV
V2 = V( IV )
T2 = TAU*V2
IV = IV + INCV
V3 = V( IV )
T3 = TAU*V3
IV = IV + INCV
V4 = V( IV )
T4 = TAU*V4
IV = IV + INCV
V5 = V( IV )
T5 = TAU*V5
IV = IV + INCV
V6 = V( IV )
T6 = TAU*V6
IV = IV + INCV
V7 = V( IV )
T7 = TAU*V7
IV = IV + INCV
V8 = V( IV )
T8 = TAU*V8
DO 180 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
$ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) +
$ V7*B( J, 7 ) + V8*B( J, 8 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
B( J, 2 ) = B( J, 2 ) - SUM*T2
B( J, 3 ) = B( J, 3 ) - SUM*T3
B( J, 4 ) = B( J, 4 ) - SUM*T4
B( J, 5 ) = B( J, 5 ) - SUM*T5
B( J, 6 ) = B( J, 6 ) - SUM*T6
B( J, 7 ) = B( J, 7 ) - SUM*T7
B( J, 8 ) = B( J, 8 ) - SUM*T8
180 CONTINUE
GO TO 210
190 CONTINUE
C
C Special code for 10 x 10 Householder
C
IV = 1
IF( INCV.LT.0 )
$ IV = (-N+1)*INCV + 1
V1 = V( IV )
T1 = TAU*V1
IV = IV + INCV
V2 = V( IV )
T2 = TAU*V2
IV = IV + INCV
V3 = V( IV )
T3 = TAU*V3
IV = IV + INCV
V4 = V( IV )
T4 = TAU*V4
IV = IV + INCV
V5 = V( IV )
T5 = TAU*V5
IV = IV + INCV
V6 = V( IV )
T6 = TAU*V6
IV = IV + INCV
V7 = V( IV )
T7 = TAU*V7
IV = IV + INCV
V8 = V( IV )
T8 = TAU*V8
IV = IV + INCV
V9 = V( IV )
T9 = TAU*V9
DO 200 J = 1, M
SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
$ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) +
$ V7*B( J, 7 ) + V8*B( J, 8 ) + V9*B( J, 9 )
A( J, 1 ) = A( J, 1 ) - SUM*TAU
B( J, 1 ) = B( J, 1 ) - SUM*T1
B( J, 2 ) = B( J, 2 ) - SUM*T2
B( J, 3 ) = B( J, 3 ) - SUM*T3
B( J, 4 ) = B( J, 4 ) - SUM*T4
B( J, 5 ) = B( J, 5 ) - SUM*T5
B( J, 6 ) = B( J, 6 ) - SUM*T6
B( J, 7 ) = B( J, 7 ) - SUM*T7
B( J, 8 ) = B( J, 8 ) - SUM*T8
B( J, 9 ) = B( J, 9 ) - SUM*T9
200 CONTINUE
210 CONTINUE
RETURN
C *** Last line of MB04NY ***
END
Reference in New Issue View Git Blame Copy Permalink