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