00001 SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, 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 CHARACTER UPLO 00010 INTEGER INFO, LDA, LWORK, N 00011 * .. 00012 * .. Array Arguments .. 00013 COMPLEX A( LDA, * ), TAU( * ), WORK( * ) 00014 * .. 00015 * 00016 * Purpose 00017 * ======= 00018 * 00019 * CUNGTR generates a complex unitary matrix Q which is defined as the 00020 * product of n-1 elementary reflectors of order N, as returned by 00021 * CHETRD: 00022 * 00023 * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), 00024 * 00025 * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). 00026 * 00027 * Arguments 00028 * ========= 00029 * 00030 * UPLO (input) CHARACTER*1 00031 * = 'U': Upper triangle of A contains elementary reflectors 00032 * from CHETRD; 00033 * = 'L': Lower triangle of A contains elementary reflectors 00034 * from CHETRD. 00035 * 00036 * N (input) INTEGER 00037 * The order of the matrix Q. N >= 0. 00038 * 00039 * A (input/output) COMPLEX array, dimension (LDA,N) 00040 * On entry, the vectors which define the elementary reflectors, 00041 * as returned by CHETRD. 00042 * On exit, the N-by-N unitary matrix Q. 00043 * 00044 * LDA (input) INTEGER 00045 * The leading dimension of the array A. LDA >= N. 00046 * 00047 * TAU (input) COMPLEX array, dimension (N-1) 00048 * TAU(i) must contain the scalar factor of the elementary 00049 * reflector H(i), as returned by CHETRD. 00050 * 00051 * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) 00052 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 00053 * 00054 * LWORK (input) INTEGER 00055 * The dimension of the array WORK. LWORK >= N-1. 00056 * For optimum performance LWORK >= (N-1)*NB, where NB is 00057 * the optimal blocksize. 00058 * 00059 * If LWORK = -1, then a workspace query is assumed; the routine 00060 * only calculates the optimal size of the WORK array, returns 00061 * this value as the first entry of the WORK array, and no error 00062 * message related to LWORK is issued by XERBLA. 00063 * 00064 * INFO (output) INTEGER 00065 * = 0: successful exit 00066 * < 0: if INFO = -i, the i-th argument had an illegal value 00067 * 00068 * ===================================================================== 00069 * 00070 * .. Parameters .. 00071 COMPLEX ZERO, ONE 00072 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), 00073 $ ONE = ( 1.0E+0, 0.0E+0 ) ) 00074 * .. 00075 * .. Local Scalars .. 00076 LOGICAL LQUERY, UPPER 00077 INTEGER I, IINFO, J, LWKOPT, NB 00078 * .. 00079 * .. External Functions .. 00080 LOGICAL LSAME 00081 INTEGER ILAENV 00082 EXTERNAL ILAENV, LSAME 00083 * .. 00084 * .. External Subroutines .. 00085 EXTERNAL CUNGQL, CUNGQR, XERBLA 00086 * .. 00087 * .. Intrinsic Functions .. 00088 INTRINSIC MAX 00089 * .. 00090 * .. Executable Statements .. 00091 * 00092 * Test the input arguments 00093 * 00094 INFO = 0 00095 LQUERY = ( LWORK.EQ.-1 ) 00096 UPPER = LSAME( UPLO, 'U' ) 00097 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 00098 INFO = -1 00099 ELSE IF( N.LT.0 ) THEN 00100 INFO = -2 00101 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 00102 INFO = -4 00103 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN 00104 INFO = -7 00105 END IF 00106 * 00107 IF( INFO.EQ.0 ) THEN 00108 IF ( UPPER ) THEN 00109 NB = ILAENV( 1, 'CUNGQL', ' ', N-1, N-1, N-1, -1 ) 00110 ELSE 00111 NB = ILAENV( 1, 'CUNGQR', ' ', N-1, N-1, N-1, -1 ) 00112 END IF 00113 LWKOPT = MAX( 1, N-1 )*NB 00114 WORK( 1 ) = LWKOPT 00115 END IF 00116 * 00117 IF( INFO.NE.0 ) THEN 00118 CALL XERBLA( 'CUNGTR', -INFO ) 00119 RETURN 00120 ELSE IF( LQUERY ) THEN 00121 RETURN 00122 END IF 00123 * 00124 * Quick return if possible 00125 * 00126 IF( N.EQ.0 ) THEN 00127 WORK( 1 ) = 1 00128 RETURN 00129 END IF 00130 * 00131 IF( UPPER ) THEN 00132 * 00133 * Q was determined by a call to CHETRD with UPLO = 'U' 00134 * 00135 * Shift the vectors which define the elementary reflectors one 00136 * column to the left, and set the last row and column of Q to 00137 * those of the unit matrix 00138 * 00139 DO 20 J = 1, N - 1 00140 DO 10 I = 1, J - 1 00141 A( I, J ) = A( I, J+1 ) 00142 10 CONTINUE 00143 A( N, J ) = ZERO 00144 20 CONTINUE 00145 DO 30 I = 1, N - 1 00146 A( I, N ) = ZERO 00147 30 CONTINUE 00148 A( N, N ) = ONE 00149 * 00150 * Generate Q(1:n-1,1:n-1) 00151 * 00152 CALL CUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) 00153 * 00154 ELSE 00155 * 00156 * Q was determined by a call to CHETRD with UPLO = 'L'. 00157 * 00158 * Shift the vectors which define the elementary reflectors one 00159 * column to the right, and set the first row and column of Q to 00160 * those of the unit matrix 00161 * 00162 DO 50 J = N, 2, -1 00163 A( 1, J ) = ZERO 00164 DO 40 I = J + 1, N 00165 A( I, J ) = A( I, J-1 ) 00166 40 CONTINUE 00167 50 CONTINUE 00168 A( 1, 1 ) = ONE 00169 DO 60 I = 2, N 00170 A( I, 1 ) = ZERO 00171 60 CONTINUE 00172 IF( N.GT.1 ) THEN 00173 * 00174 * Generate Q(2:n,2:n) 00175 * 00176 CALL CUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, 00177 $ LWORK, IINFO ) 00178 END IF 00179 END IF 00180 WORK( 1 ) = LWKOPT 00181 RETURN 00182 * 00183 * End of CUNGTR 00184 * 00185 END
1.7.2