LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ sorgtr()

subroutine sorgtr ( character  UPLO,
integer  N,
real, dimension( lda, * )  A,
integer  LDA,
real, dimension( * )  TAU,
real, dimension( * )  WORK,
integer  LWORK,
integer  INFO 
)

SORGTR

Download SORGTR + dependencies [TGZ] [ZIP] [TXT]

Purpose:
 SORGTR generates a real orthogonal matrix Q which is defined as the
 product of n-1 elementary reflectors of order N, as returned by
 SSYTRD:

 if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),

 if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
Parameters
[in]UPLO
          UPLO is CHARACTER*1
          = 'U': Upper triangle of A contains elementary reflectors
                 from SSYTRD;
          = 'L': Lower triangle of A contains elementary reflectors
                 from SSYTRD.
[in]N
          N is INTEGER
          The order of the matrix Q. N >= 0.
[in,out]A
          A is REAL array, dimension (LDA,N)
          On entry, the vectors which define the elementary reflectors,
          as returned by SSYTRD.
          On exit, the N-by-N orthogonal matrix Q.
[in]LDA
          LDA is INTEGER
          The leading dimension of the array A. LDA >= max(1,N).
[in]TAU
          TAU is REAL array, dimension (N-1)
          TAU(i) must contain the scalar factor of the elementary
          reflector H(i), as returned by SSYTRD.
[out]WORK
          WORK is REAL array, dimension (MAX(1,LWORK))
          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
[in]LWORK
          LWORK is INTEGER
          The dimension of the array WORK. LWORK >= max(1,N-1).
          For optimum performance LWORK >= (N-1)*NB, where NB is
          the optimal blocksize.

          If LWORK = -1, then a workspace query is assumed; the routine
          only calculates the optimal size of the WORK array, returns
          this value as the first entry of the WORK array, and no error
          message related to LWORK is issued by XERBLA.
[out]INFO
          INFO is INTEGER
          = 0:  successful exit
          < 0:  if INFO = -i, the i-th argument had an illegal value
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
December 2016

Definition at line 125 of file sorgtr.f.

125 *
126 * -- LAPACK computational routine (version 3.7.0) --
127 * -- LAPACK is a software package provided by Univ. of Tennessee, --
128 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129 * December 2016
130 *
131 * .. Scalar Arguments ..
132  CHARACTER uplo
133  INTEGER info, lda, lwork, n
134 * ..
135 * .. Array Arguments ..
136  REAL a( lda, * ), tau( * ), work( * )
137 * ..
138 *
139 * =====================================================================
140 *
141 * .. Parameters ..
142  REAL zero, one
143  parameter( zero = 0.0e+0, one = 1.0e+0 )
144 * ..
145 * .. Local Scalars ..
146  LOGICAL lquery, upper
147  INTEGER i, iinfo, j, lwkopt, nb
148 * ..
149 * .. External Functions ..
150  LOGICAL lsame
151  INTEGER ilaenv
152  EXTERNAL ilaenv, lsame
153 * ..
154 * .. External Subroutines ..
155  EXTERNAL sorgql, sorgqr, xerbla
156 * ..
157 * .. Intrinsic Functions ..
158  INTRINSIC max
159 * ..
160 * .. Executable Statements ..
161 *
162 * Test the input arguments
163 *
164  info = 0
165  lquery = ( lwork.EQ.-1 )
166  upper = lsame( uplo, 'U' )
167  IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
168  info = -1
169  ELSE IF( n.LT.0 ) THEN
170  info = -2
171  ELSE IF( lda.LT.max( 1, n ) ) THEN
172  info = -4
173  ELSE IF( lwork.LT.max( 1, n-1 ) .AND. .NOT.lquery ) THEN
174  info = -7
175  END IF
176 *
177  IF( info.EQ.0 ) THEN
178  IF ( upper ) THEN
179  nb = ilaenv( 1, 'SORGQL', ' ', n-1, n-1, n-1, -1 )
180  ELSE
181  nb = ilaenv( 1, 'SORGQR', ' ', n-1, n-1, n-1, -1 )
182  END IF
183  lwkopt = max( 1, n-1 )*nb
184  work( 1 ) = lwkopt
185  END IF
186 *
187  IF( info.NE.0 ) THEN
188  CALL xerbla( 'SORGTR', -info )
189  RETURN
190  ELSE IF( lquery ) THEN
191  RETURN
192  END IF
193 *
194 * Quick return if possible
195 *
196  IF( n.EQ.0 ) THEN
197  work( 1 ) = 1
198  RETURN
199  END IF
200 *
201  IF( upper ) THEN
202 *
203 * Q was determined by a call to SSYTRD with UPLO = 'U'
204 *
205 * Shift the vectors which define the elementary reflectors one
206 * column to the left, and set the last row and column of Q to
207 * those of the unit matrix
208 *
209  DO 20 j = 1, n - 1
210  DO 10 i = 1, j - 1
211  a( i, j ) = a( i, j+1 )
212  10 CONTINUE
213  a( n, j ) = zero
214  20 CONTINUE
215  DO 30 i = 1, n - 1
216  a( i, n ) = zero
217  30 CONTINUE
218  a( n, n ) = one
219 *
220 * Generate Q(1:n-1,1:n-1)
221 *
222  CALL sorgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
223 *
224  ELSE
225 *
226 * Q was determined by a call to SSYTRD with UPLO = 'L'.
227 *
228 * Shift the vectors which define the elementary reflectors one
229 * column to the right, and set the first row and column of Q to
230 * those of the unit matrix
231 *
232  DO 50 j = n, 2, -1
233  a( 1, j ) = zero
234  DO 40 i = j + 1, n
235  a( i, j ) = a( i, j-1 )
236  40 CONTINUE
237  50 CONTINUE
238  a( 1, 1 ) = one
239  DO 60 i = 2, n
240  a( i, 1 ) = zero
241  60 CONTINUE
242  IF( n.GT.1 ) THEN
243 *
244 * Generate Q(2:n,2:n)
245 *
246  CALL sorgqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,
247  $ lwork, iinfo )
248  END IF
249  END IF
250  work( 1 ) = lwkopt
251  RETURN
252 *
253 * End of SORGTR
254 *
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
ILAENV
Definition: tstiee.f:83
subroutine sorgql(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGQL
Definition: sorgql.f:130
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
subroutine sorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
SORGQR
Definition: sorgqr.f:130
Here is the call graph for this function:
Here is the caller graph for this function: