|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, 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, LDC, M, N 00011 REAL TAU 00012 * .. 00013 * .. Array Arguments .. 00014 REAL C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * This routine is deprecated and has been replaced by routine SORMRZ. 00021 * 00022 * SLATZM applies a Householder matrix generated by STZRQF to a matrix. 00023 * 00024 * Let P = I - tau*u*u', u = ( 1 ), 00025 * ( v ) 00026 * where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if 00027 * SIDE = 'R'. 00028 * 00029 * If SIDE equals 'L', let 00030 * C = [ C1 ] 1 00031 * [ C2 ] m-1 00032 * n 00033 * Then C is overwritten by P*C. 00034 * 00035 * If SIDE equals 'R', let 00036 * C = [ C1, C2 ] m 00037 * 1 n-1 00038 * Then C is overwritten by C*P. 00039 * 00040 * Arguments 00041 * ========= 00042 * 00043 * SIDE (input) CHARACTER*1 00044 * = 'L': form P * C 00045 * = 'R': form C * P 00046 * 00047 * M (input) INTEGER 00048 * The number of rows of the matrix C. 00049 * 00050 * N (input) INTEGER 00051 * The number of columns of the matrix C. 00052 * 00053 * V (input) REAL array, dimension 00054 * (1 + (M-1)*abs(INCV)) if SIDE = 'L' 00055 * (1 + (N-1)*abs(INCV)) if SIDE = 'R' 00056 * The vector v in the representation of P. V is not used 00057 * if TAU = 0. 00058 * 00059 * INCV (input) INTEGER 00060 * The increment between elements of v. INCV <> 0 00061 * 00062 * TAU (input) REAL 00063 * The value tau in the representation of P. 00064 * 00065 * C1 (input/output) REAL array, dimension 00066 * (LDC,N) if SIDE = 'L' 00067 * (M,1) if SIDE = 'R' 00068 * On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 00069 * if SIDE = 'R'. 00070 * 00071 * On exit, the first row of P*C if SIDE = 'L', or the first 00072 * column of C*P if SIDE = 'R'. 00073 * 00074 * C2 (input/output) REAL array, dimension 00075 * (LDC, N) if SIDE = 'L' 00076 * (LDC, N-1) if SIDE = 'R' 00077 * On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the 00078 * m x (n - 1) matrix C2 if SIDE = 'R'. 00079 * 00080 * On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P 00081 * if SIDE = 'R'. 00082 * 00083 * LDC (input) INTEGER 00084 * The leading dimension of the arrays C1 and C2. LDC >= (1,M). 00085 * 00086 * WORK (workspace) REAL array, dimension 00087 * (N) if SIDE = 'L' 00088 * (M) if SIDE = 'R' 00089 * 00090 * ===================================================================== 00091 * 00092 * .. Parameters .. 00093 REAL ONE, ZERO 00094 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00095 * .. 00096 * .. External Subroutines .. 00097 EXTERNAL SAXPY, SCOPY, SGEMV, SGER 00098 * .. 00099 * .. External Functions .. 00100 LOGICAL LSAME 00101 EXTERNAL LSAME 00102 * .. 00103 * .. Intrinsic Functions .. 00104 INTRINSIC MIN 00105 * .. 00106 * .. Executable Statements .. 00107 * 00108 IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) ) 00109 $ RETURN 00110 * 00111 IF( LSAME( SIDE, 'L' ) ) THEN 00112 * 00113 * w := C1 + v' * C2 00114 * 00115 CALL SCOPY( N, C1, LDC, WORK, 1 ) 00116 CALL SGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE, 00117 $ WORK, 1 ) 00118 * 00119 * [ C1 ] := [ C1 ] - tau* [ 1 ] * w' 00120 * [ C2 ] [ C2 ] [ v ] 00121 * 00122 CALL SAXPY( N, -TAU, WORK, 1, C1, LDC ) 00123 CALL SGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC ) 00124 * 00125 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 00126 * 00127 * w := C1 + C2 * v 00128 * 00129 CALL SCOPY( M, C1, 1, WORK, 1 ) 00130 CALL SGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE, 00131 $ WORK, 1 ) 00132 * 00133 * [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] 00134 * 00135 CALL SAXPY( M, -TAU, WORK, 1, C1, 1 ) 00136 CALL SGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC ) 00137 END IF 00138 * 00139 RETURN 00140 * 00141 * End of SLATZM 00142 * 00143 END
1.7.3 
