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