|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) 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 INTEGER INFO, K, LDA, M, N 00010 * .. 00011 * .. Array Arguments .. 00012 REAL A( LDA, * ), TAU( * ), WORK( * ) 00013 * .. 00014 * 00015 * Purpose 00016 * ======= 00017 * 00018 * SORGL2 generates an m by n real matrix Q with orthonormal rows, 00019 * which is defined as the first m rows of a product of k elementary 00020 * reflectors of order n 00021 * 00022 * Q = H(k) . . . H(2) H(1) 00023 * 00024 * as returned by SGELQF. 00025 * 00026 * Arguments 00027 * ========= 00028 * 00029 * M (input) INTEGER 00030 * The number of rows of the matrix Q. M >= 0. 00031 * 00032 * N (input) INTEGER 00033 * The number of columns of the matrix Q. N >= M. 00034 * 00035 * K (input) INTEGER 00036 * The number of elementary reflectors whose product defines the 00037 * matrix Q. M >= K >= 0. 00038 * 00039 * A (input/output) REAL array, dimension (LDA,N) 00040 * On entry, the i-th row must contain the vector which defines 00041 * the elementary reflector H(i), for i = 1,2,...,k, as returned 00042 * by SGELQF in the first k rows of its array argument A. 00043 * On exit, the m-by-n matrix Q. 00044 * 00045 * LDA (input) INTEGER 00046 * The first dimension of the array A. LDA >= max(1,M). 00047 * 00048 * TAU (input) REAL array, dimension (K) 00049 * TAU(i) must contain the scalar factor of the elementary 00050 * reflector H(i), as returned by SGELQF. 00051 * 00052 * WORK (workspace) REAL array, dimension (M) 00053 * 00054 * INFO (output) INTEGER 00055 * = 0: successful exit 00056 * < 0: if INFO = -i, the i-th argument has an illegal value 00057 * 00058 * ===================================================================== 00059 * 00060 * .. Parameters .. 00061 REAL ONE, ZERO 00062 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00063 * .. 00064 * .. Local Scalars .. 00065 INTEGER I, J, L 00066 * .. 00067 * .. External Subroutines .. 00068 EXTERNAL SLARF, SSCAL, XERBLA 00069 * .. 00070 * .. Intrinsic Functions .. 00071 INTRINSIC MAX 00072 * .. 00073 * .. Executable Statements .. 00074 * 00075 * Test the input arguments 00076 * 00077 INFO = 0 00078 IF( M.LT.0 ) THEN 00079 INFO = -1 00080 ELSE IF( N.LT.M ) THEN 00081 INFO = -2 00082 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN 00083 INFO = -3 00084 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 00085 INFO = -5 00086 END IF 00087 IF( INFO.NE.0 ) THEN 00088 CALL XERBLA( 'SORGL2', -INFO ) 00089 RETURN 00090 END IF 00091 * 00092 * Quick return if possible 00093 * 00094 IF( M.LE.0 ) 00095 $ RETURN 00096 * 00097 IF( K.LT.M ) THEN 00098 * 00099 * Initialise rows k+1:m to rows of the unit matrix 00100 * 00101 DO 20 J = 1, N 00102 DO 10 L = K + 1, M 00103 A( L, J ) = ZERO 00104 10 CONTINUE 00105 IF( J.GT.K .AND. J.LE.M ) 00106 $ A( J, J ) = ONE 00107 20 CONTINUE 00108 END IF 00109 * 00110 DO 40 I = K, 1, -1 00111 * 00112 * Apply H(i) to A(i:m,i:n) from the right 00113 * 00114 IF( I.LT.N ) THEN 00115 IF( I.LT.M ) THEN 00116 A( I, I ) = ONE 00117 CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, 00118 $ TAU( I ), A( I+1, I ), LDA, WORK ) 00119 END IF 00120 CALL SSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) 00121 END IF 00122 A( I, I ) = ONE - TAU( I ) 00123 * 00124 * Set A(i,1:i-1) to zero 00125 * 00126 DO 30 L = 1, I - 1 00127 A( I, L ) = ZERO 00128 30 CONTINUE 00129 40 CONTINUE 00130 RETURN 00131 * 00132 * End of SORGL2 00133 * 00134 END
1.7.3 
