1 SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) 2* 3* -- LAPACK routine (version 3.0) -- 4* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 5* Courant Institute, Argonne National Lab, and Rice University 6* June 30, 1999 7* 8* .. Scalar Arguments .. 9 CHARACTER UPLO 10 INTEGER INFO, LDA, LWORK, N 11* .. 12* .. Array Arguments .. 13 COMPLEX A( LDA, * ), TAU( * ), WORK( * ) 14* .. 15* 16* Purpose 17* ======= 18* 19* CUNGTR generates a complex unitary matrix Q which is defined as the 20* product of n-1 elementary reflectors of order N, as returned by 21* CHETRD: 22* 23* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), 24* 25* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). 26* 27* Arguments 28* ========= 29* 30* UPLO (input) CHARACTER*1 31* = 'U': Upper triangle of A contains elementary reflectors 32* from CHETRD; 33* = 'L': Lower triangle of A contains elementary reflectors 34* from CHETRD. 35* 36* N (input) INTEGER 37* The order of the matrix Q. N >= 0. 38* 39* A (input/output) COMPLEX array, dimension (LDA,N) 40* On entry, the vectors which define the elementary reflectors, 41* as returned by CHETRD. 42* On exit, the N-by-N unitary matrix Q. 43* 44* LDA (input) INTEGER 45* The leading dimension of the array A. LDA >= N. 46* 47* TAU (input) COMPLEX array, dimension (N-1) 48* TAU(i) must contain the scalar factor of the elementary 49* reflector H(i), as returned by CHETRD. 50* 51* WORK (workspace/output) COMPLEX array, dimension (LWORK) 52* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 53* 54* LWORK (input) INTEGER 55* The dimension of the array WORK. LWORK >= N-1. 56* For optimum performance LWORK >= (N-1)*NB, where NB is 57* the optimal blocksize. 58* 59* If LWORK = -1, then a workspace query is assumed; the routine 60* only calculates the optimal size of the WORK array, returns 61* this value as the first entry of the WORK array, and no error 62* message related to LWORK is issued by XERBLA. 63* 64* INFO (output) INTEGER 65* = 0: successful exit 66* < 0: if INFO = -i, the i-th argument had an illegal value 67* 68* ===================================================================== 69* 70* .. Parameters .. 71 COMPLEX ZERO, ONE 72 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), 73 $ ONE = ( 1.0E+0, 0.0E+0 ) ) 74* .. 75* .. Local Scalars .. 76 LOGICAL LQUERY, UPPER 77 INTEGER I, IINFO, J, LWKOPT, NB 78* .. 79* .. External Functions .. 80 LOGICAL LSAME 81 INTEGER ILAENV 82 EXTERNAL ILAENV, LSAME 83* .. 84* .. External Subroutines .. 85 EXTERNAL CUNGQL, CUNGQR, XERBLA 86* .. 87* .. Intrinsic Functions .. 88 INTRINSIC MAX 89* .. 90* .. Executable Statements .. 91* 92* Test the input arguments 93* 94 INFO = 0 95 LQUERY = ( LWORK.EQ.-1 ) 96 UPPER = LSAME( UPLO, 'U' ) 97 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 98 INFO = -1 99 ELSE IF( N.LT.0 ) THEN 100 INFO = -2 101 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 102 INFO = -4 103 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN 104 INFO = -7 105 END IF 106* 107 IF( INFO.EQ.0 ) THEN 108 IF ( UPPER ) THEN 109 NB = ILAENV( 1, 'CUNGQL', ' ', N-1, N-1, N-1, -1 ) 110 ELSE 111 NB = ILAENV( 1, 'CUNGQR', ' ', N-1, N-1, N-1, -1 ) 112 END IF 113 LWKOPT = MAX( 1, N-1 )*NB 114 WORK( 1 ) = LWKOPT 115 END IF 116* 117 IF( INFO.NE.0 ) THEN 118 CALL XERBLA( 'CUNGTR', -INFO ) 119 RETURN 120 ELSE IF( LQUERY ) THEN 121 RETURN 122 END IF 123* 124* Quick return if possible 125* 126 IF( N.EQ.0 ) THEN 127 WORK( 1 ) = 1 128 RETURN 129 END IF 130* 131 IF( UPPER ) THEN 132* 133* Q was determined by a call to CHETRD with UPLO = 'U' 134* 135* Shift the vectors which define the elementary reflectors one 136* column to the left, and set the last row and column of Q to 137* those of the unit matrix 138* 139 DO 20 J = 1, N - 1 140 DO 10 I = 1, J - 1 141 A( I, J ) = A( I, J+1 ) 142 10 CONTINUE 143 A( N, J ) = ZERO 144 20 CONTINUE 145 DO 30 I = 1, N - 1 146 A( I, N ) = ZERO 147 30 CONTINUE 148 A( N, N ) = ONE 149* 150* Generate Q(1:n-1,1:n-1) 151* 152 CALL CUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) 153* 154 ELSE 155* 156* Q was determined by a call to CHETRD with UPLO = 'L'. 157* 158* Shift the vectors which define the elementary reflectors one 159* column to the right, and set the first row and column of Q to 160* those of the unit matrix 161* 162 DO 50 J = N, 2, -1 163 A( 1, J ) = ZERO 164 DO 40 I = J + 1, N 165 A( I, J ) = A( I, J-1 ) 166 40 CONTINUE 167 50 CONTINUE 168 A( 1, 1 ) = ONE 169 DO 60 I = 2, N 170 A( I, 1 ) = ZERO 171 60 CONTINUE 172 IF( N.GT.1 ) THEN 173* 174* Generate Q(2:n,2:n) 175* 176 CALL CUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, 177 $ LWORK, IINFO ) 178 END IF 179 END IF 180 WORK( 1 ) = LWKOPT 181 RETURN 182* 183* End of CUNGTR 184* 185 END 186