![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SLARF 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download SLARF + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarf.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarf.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarf.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) 00022 * 00023 * .. Scalar Arguments .. 00024 * CHARACTER SIDE 00025 * INTEGER INCV, LDC, M, N 00026 * REAL TAU 00027 * .. 00028 * .. Array Arguments .. 00029 * REAL C( LDC, * ), V( * ), WORK( * ) 00030 * .. 00031 * 00032 * 00033 *> \par Purpose: 00034 * ============= 00035 *> 00036 *> \verbatim 00037 *> 00038 *> SLARF applies a real elementary reflector H to a real m by n matrix 00039 *> C, from either the left or the right. H is represented in the form 00040 *> 00041 *> H = I - tau * v * v**T 00042 *> 00043 *> where tau is a real scalar and v is a real vector. 00044 *> 00045 *> If tau = 0, then H is taken to be the unit matrix. 00046 *> \endverbatim 00047 * 00048 * Arguments: 00049 * ========== 00050 * 00051 *> \param[in] SIDE 00052 *> \verbatim 00053 *> SIDE is CHARACTER*1 00054 *> = 'L': form H * C 00055 *> = 'R': form C * H 00056 *> \endverbatim 00057 *> 00058 *> \param[in] M 00059 *> \verbatim 00060 *> M is INTEGER 00061 *> The number of rows of the matrix C. 00062 *> \endverbatim 00063 *> 00064 *> \param[in] N 00065 *> \verbatim 00066 *> N is INTEGER 00067 *> The number of columns of the matrix C. 00068 *> \endverbatim 00069 *> 00070 *> \param[in] V 00071 *> \verbatim 00072 *> V is REAL array, dimension 00073 *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' 00074 *> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' 00075 *> The vector v in the representation of H. V is not used if 00076 *> TAU = 0. 00077 *> \endverbatim 00078 *> 00079 *> \param[in] INCV 00080 *> \verbatim 00081 *> INCV is INTEGER 00082 *> The increment between elements of v. INCV <> 0. 00083 *> \endverbatim 00084 *> 00085 *> \param[in] TAU 00086 *> \verbatim 00087 *> TAU is REAL 00088 *> The value tau in the representation of H. 00089 *> \endverbatim 00090 *> 00091 *> \param[in,out] C 00092 *> \verbatim 00093 *> C is REAL array, dimension (LDC,N) 00094 *> On entry, the m by n matrix C. 00095 *> On exit, C is overwritten by the matrix H * C if SIDE = 'L', 00096 *> or C * H if SIDE = 'R'. 00097 *> \endverbatim 00098 *> 00099 *> \param[in] LDC 00100 *> \verbatim 00101 *> LDC is INTEGER 00102 *> The leading dimension of the array C. LDC >= max(1,M). 00103 *> \endverbatim 00104 *> 00105 *> \param[out] WORK 00106 *> \verbatim 00107 *> WORK is REAL array, dimension 00108 *> (N) if SIDE = 'L' 00109 *> or (M) if SIDE = 'R' 00110 *> \endverbatim 00111 * 00112 * Authors: 00113 * ======== 00114 * 00115 *> \author Univ. of Tennessee 00116 *> \author Univ. of California Berkeley 00117 *> \author Univ. of Colorado Denver 00118 *> \author NAG Ltd. 00119 * 00120 *> \date November 2011 00121 * 00122 *> \ingroup realOTHERauxiliary 00123 * 00124 * ===================================================================== 00125 SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) 00126 * 00127 * -- LAPACK auxiliary routine (version 3.4.0) -- 00128 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00129 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00130 * November 2011 00131 * 00132 * .. Scalar Arguments .. 00133 CHARACTER SIDE 00134 INTEGER INCV, LDC, M, N 00135 REAL TAU 00136 * .. 00137 * .. Array Arguments .. 00138 REAL C( LDC, * ), V( * ), WORK( * ) 00139 * .. 00140 * 00141 * ===================================================================== 00142 * 00143 * .. Parameters .. 00144 REAL ONE, ZERO 00145 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00146 * .. 00147 * .. Local Scalars .. 00148 LOGICAL APPLYLEFT 00149 INTEGER I, LASTV, LASTC 00150 * .. 00151 * .. External Subroutines .. 00152 EXTERNAL SGEMV, SGER 00153 * .. 00154 * .. External Functions .. 00155 LOGICAL LSAME 00156 INTEGER ILASLR, ILASLC 00157 EXTERNAL LSAME, ILASLR, ILASLC 00158 * .. 00159 * .. Executable Statements .. 00160 * 00161 APPLYLEFT = LSAME( SIDE, 'L' ) 00162 LASTV = 0 00163 LASTC = 0 00164 IF( TAU.NE.ZERO ) THEN 00165 ! Set up variables for scanning V. LASTV begins pointing to the end 00166 ! of V. 00167 IF( APPLYLEFT ) THEN 00168 LASTV = M 00169 ELSE 00170 LASTV = N 00171 END IF 00172 IF( INCV.GT.0 ) THEN 00173 I = 1 + (LASTV-1) * INCV 00174 ELSE 00175 I = 1 00176 END IF 00177 ! Look for the last non-zero row in V. 00178 DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) 00179 LASTV = LASTV - 1 00180 I = I - INCV 00181 END DO 00182 IF( APPLYLEFT ) THEN 00183 ! Scan for the last non-zero column in C(1:lastv,:). 00184 LASTC = ILASLC(LASTV, N, C, LDC) 00185 ELSE 00186 ! Scan for the last non-zero row in C(:,1:lastv). 00187 LASTC = ILASLR(M, LASTV, C, LDC) 00188 END IF 00189 END IF 00190 ! Note that lastc.eq.0 renders the BLAS operations null; no special 00191 ! case is needed at this level. 00192 IF( APPLYLEFT ) THEN 00193 * 00194 * Form H * C 00195 * 00196 IF( LASTV.GT.0 ) THEN 00197 * 00198 * w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) 00199 * 00200 CALL SGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, 00201 $ ZERO, WORK, 1 ) 00202 * 00203 * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T 00204 * 00205 CALL SGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) 00206 END IF 00207 ELSE 00208 * 00209 * Form C * H 00210 * 00211 IF( LASTV.GT.0 ) THEN 00212 * 00213 * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) 00214 * 00215 CALL SGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, 00216 $ V, INCV, ZERO, WORK, 1 ) 00217 * 00218 * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T 00219 * 00220 CALL SGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) 00221 END IF 00222 END IF 00223 RETURN 00224 * 00225 * End of SLARF 00226 * 00227 END