00001 SUBROUTINE SORGTR( 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 REAL A( LDA, * ), TAU( * ), WORK( * ) 00014 * .. 00015 * 00016 * Purpose 00017 * ======= 00018 * 00019 * SORGTR generates a real orthogonal matrix Q which is defined as the 00020 * product of n-1 elementary reflectors of order N, as returned by 00021 * SSYTRD: 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 SSYTRD; 00033 * = 'L': Lower triangle of A contains elementary reflectors 00034 * from SSYTRD. 00035 * 00036 * N (input) INTEGER 00037 * The order of the matrix Q. N >= 0. 00038 * 00039 * A (input/output) REAL array, dimension (LDA,N) 00040 * On entry, the vectors which define the elementary reflectors, 00041 * as returned by SSYTRD. 00042 * On exit, the N-by-N orthogonal matrix Q. 00043 * 00044 * LDA (input) INTEGER 00045 * The leading dimension of the array A. LDA >= max(1,N). 00046 * 00047 * TAU (input) REAL array, dimension (N-1) 00048 * TAU(i) must contain the scalar factor of the elementary 00049 * reflector H(i), as returned by SSYTRD. 00050 * 00051 * WORK (workspace/output) REAL 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 >= max(1,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 REAL ZERO, ONE 00072 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) 00073 * .. 00074 * .. Local Scalars .. 00075 LOGICAL LQUERY, UPPER 00076 INTEGER I, IINFO, J, LWKOPT, NB 00077 * .. 00078 * .. External Functions .. 00079 LOGICAL LSAME 00080 INTEGER ILAENV 00081 EXTERNAL ILAENV, LSAME 00082 * .. 00083 * .. External Subroutines .. 00084 EXTERNAL SORGQL, SORGQR, XERBLA 00085 * .. 00086 * .. Intrinsic Functions .. 00087 INTRINSIC MAX 00088 * .. 00089 * .. Executable Statements .. 00090 * 00091 * Test the input arguments 00092 * 00093 INFO = 0 00094 LQUERY = ( LWORK.EQ.-1 ) 00095 UPPER = LSAME( UPLO, 'U' ) 00096 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 00097 INFO = -1 00098 ELSE IF( N.LT.0 ) THEN 00099 INFO = -2 00100 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 00101 INFO = -4 00102 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN 00103 INFO = -7 00104 END IF 00105 * 00106 IF( INFO.EQ.0 ) THEN 00107 IF ( UPPER ) THEN 00108 NB = ILAENV( 1, 'SORGQL', ' ', N-1, N-1, N-1, -1 ) 00109 ELSE 00110 NB = ILAENV( 1, 'SORGQR', ' ', N-1, N-1, N-1, -1 ) 00111 END IF 00112 LWKOPT = MAX( 1, N-1 )*NB 00113 WORK( 1 ) = LWKOPT 00114 END IF 00115 * 00116 IF( INFO.NE.0 ) THEN 00117 CALL XERBLA( 'SORGTR', -INFO ) 00118 RETURN 00119 ELSE IF( LQUERY ) THEN 00120 RETURN 00121 END IF 00122 * 00123 * Quick return if possible 00124 * 00125 IF( N.EQ.0 ) THEN 00126 WORK( 1 ) = 1 00127 RETURN 00128 END IF 00129 * 00130 IF( UPPER ) THEN 00131 * 00132 * Q was determined by a call to SSYTRD with UPLO = 'U' 00133 * 00134 * Shift the vectors which define the elementary reflectors one 00135 * column to the left, and set the last row and column of Q to 00136 * those of the unit matrix 00137 * 00138 DO 20 J = 1, N - 1 00139 DO 10 I = 1, J - 1 00140 A( I, J ) = A( I, J+1 ) 00141 10 CONTINUE 00142 A( N, J ) = ZERO 00143 20 CONTINUE 00144 DO 30 I = 1, N - 1 00145 A( I, N ) = ZERO 00146 30 CONTINUE 00147 A( N, N ) = ONE 00148 * 00149 * Generate Q(1:n-1,1:n-1) 00150 * 00151 CALL SORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) 00152 * 00153 ELSE 00154 * 00155 * Q was determined by a call to SSYTRD with UPLO = 'L'. 00156 * 00157 * Shift the vectors which define the elementary reflectors one 00158 * column to the right, and set the first row and column of Q to 00159 * those of the unit matrix 00160 * 00161 DO 50 J = N, 2, -1 00162 A( 1, J ) = ZERO 00163 DO 40 I = J + 1, N 00164 A( I, J ) = A( I, J-1 ) 00165 40 CONTINUE 00166 50 CONTINUE 00167 A( 1, 1 ) = ONE 00168 DO 60 I = 2, N 00169 A( I, 1 ) = ZERO 00170 60 CONTINUE 00171 IF( N.GT.1 ) THEN 00172 * 00173 * Generate Q(2:n,2:n) 00174 * 00175 CALL SORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, 00176 $ LWORK, IINFO ) 00177 END IF 00178 END IF 00179 WORK( 1 ) = LWKOPT 00180 RETURN 00181 * 00182 * End of SORGTR 00183 * 00184 END
1.7.2