00001 SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) 00002 * 00003 * -- LAPACK routine (version 3.2) -- 00004 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00005 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 CHARACTER SIDE 00010 INTEGER INCV, L, LDC, M, N 00011 REAL TAU 00012 * .. 00013 * .. Array Arguments .. 00014 REAL C( LDC, * ), V( * ), WORK( * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * SLARZ applies a real elementary reflector H to a real M-by-N 00021 * matrix C, from either the left or the right. H is represented in the 00022 * form 00023 * 00024 * H = I - tau * v * v' 00025 * 00026 * where tau is a real scalar and v is a real vector. 00027 * 00028 * If tau = 0, then H is taken to be the unit matrix. 00029 * 00030 * 00031 * H is a product of k elementary reflectors as returned by STZRZF. 00032 * 00033 * Arguments 00034 * ========= 00035 * 00036 * SIDE (input) CHARACTER*1 00037 * = 'L': form H * C 00038 * = 'R': form C * H 00039 * 00040 * M (input) INTEGER 00041 * The number of rows of the matrix C. 00042 * 00043 * N (input) INTEGER 00044 * The number of columns of the matrix C. 00045 * 00046 * L (input) INTEGER 00047 * The number of entries of the vector V containing 00048 * the meaningful part of the Householder vectors. 00049 * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. 00050 * 00051 * V (input) REAL array, dimension (1+(L-1)*abs(INCV)) 00052 * The vector v in the representation of H as returned by 00053 * STZRZF. V is not used if TAU = 0. 00054 * 00055 * INCV (input) INTEGER 00056 * The increment between elements of v. INCV <> 0. 00057 * 00058 * TAU (input) REAL 00059 * The value tau in the representation of H. 00060 * 00061 * C (input/output) REAL array, dimension (LDC,N) 00062 * On entry, the M-by-N matrix C. 00063 * On exit, C is overwritten by the matrix H * C if SIDE = 'L', 00064 * or C * H if SIDE = 'R'. 00065 * 00066 * LDC (input) INTEGER 00067 * The leading dimension of the array C. LDC >= max(1,M). 00068 * 00069 * WORK (workspace) REAL array, dimension 00070 * (N) if SIDE = 'L' 00071 * or (M) if SIDE = 'R' 00072 * 00073 * Further Details 00074 * =============== 00075 * 00076 * Based on contributions by 00077 * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA 00078 * 00079 * ===================================================================== 00080 * 00081 * .. Parameters .. 00082 REAL ONE, ZERO 00083 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00084 * .. 00085 * .. External Subroutines .. 00086 EXTERNAL SAXPY, SCOPY, SGEMV, SGER 00087 * .. 00088 * .. External Functions .. 00089 LOGICAL LSAME 00090 EXTERNAL LSAME 00091 * .. 00092 * .. Executable Statements .. 00093 * 00094 IF( LSAME( SIDE, 'L' ) ) THEN 00095 * 00096 * Form H * C 00097 * 00098 IF( TAU.NE.ZERO ) THEN 00099 * 00100 * w( 1:n ) = C( 1, 1:n ) 00101 * 00102 CALL SCOPY( N, C, LDC, WORK, 1 ) 00103 * 00104 * w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) 00105 * 00106 CALL SGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V, 00107 $ INCV, ONE, WORK, 1 ) 00108 * 00109 * C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) 00110 * 00111 CALL SAXPY( N, -TAU, WORK, 1, C, LDC ) 00112 * 00113 * C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... 00114 * tau * v( 1:l ) * w( 1:n )' 00115 * 00116 CALL SGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ), 00117 $ LDC ) 00118 END IF 00119 * 00120 ELSE 00121 * 00122 * Form C * H 00123 * 00124 IF( TAU.NE.ZERO ) THEN 00125 * 00126 * w( 1:m ) = C( 1:m, 1 ) 00127 * 00128 CALL SCOPY( M, C, 1, WORK, 1 ) 00129 * 00130 * w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) 00131 * 00132 CALL SGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC, 00133 $ V, INCV, ONE, WORK, 1 ) 00134 * 00135 * C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) 00136 * 00137 CALL SAXPY( M, -TAU, WORK, 1, C, 1 ) 00138 * 00139 * C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... 00140 * tau * w( 1:m ) * v( 1:l )' 00141 * 00142 CALL SGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ), 00143 $ LDC ) 00144 * 00145 END IF 00146 * 00147 END IF 00148 * 00149 RETURN 00150 * 00151 * End of SLARZ 00152 * 00153 END
1.7.2