1 SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
2 $ WORK, LWORK, INFO )
3 *
4 * -- LAPACK routine (version 3.2) --
5 * -- LAPACK is a software package provided by Univ. of Tennessee, --
6 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7 * November 2006
8 *
9 * .. Scalar Arguments ..
10 CHARACTER SIDE, TRANS, UPLO
11 INTEGER INFO, LDA, LDC, LWORK, M, N
12 * ..
13 * .. Array Arguments ..
14 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
15 * ..
16 *
17 * Purpose
18 * =======
19 *
20 * DORMTR overwrites the general real M-by-N matrix C with
21 *
22 * SIDE = 'L' SIDE = 'R'
23 * TRANS = 'N': Q * C C * Q
24 * TRANS = 'T': Q**T * C C * Q**T
25 *
26 * where Q is a real orthogonal matrix of order nq, with nq = m if
27 * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
28 * nq-1 elementary reflectors, as returned by DSYTRD:
29 *
30 * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
31 *
32 * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
33 *
34 * Arguments
35 * =========
36 *
37 * SIDE (input) CHARACTER*1
38 * = 'L': apply Q or Q**T from the Left;
39 * = 'R': apply Q or Q**T from the Right.
40 *
41 * UPLO (input) CHARACTER*1
42 * = 'U': Upper triangle of A contains elementary reflectors
43 * from DSYTRD;
44 * = 'L': Lower triangle of A contains elementary reflectors
45 * from DSYTRD.
46 *
47 * TRANS (input) CHARACTER*1
48 * = 'N': No transpose, apply Q;
49 * = 'T': Transpose, apply Q**T.
50 *
51 * M (input) INTEGER
52 * The number of rows of the matrix C. M >= 0.
53 *
54 * N (input) INTEGER
55 * The number of columns of the matrix C. N >= 0.
56 *
57 * A (input) DOUBLE PRECISION array, dimension
58 * (LDA,M) if SIDE = 'L'
59 * (LDA,N) if SIDE = 'R'
60 * The vectors which define the elementary reflectors, as
61 * returned by DSYTRD.
62 *
63 * LDA (input) INTEGER
64 * The leading dimension of the array A.
65 * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
66 *
67 * TAU (input) DOUBLE PRECISION array, dimension
68 * (M-1) if SIDE = 'L'
69 * (N-1) if SIDE = 'R'
70 * TAU(i) must contain the scalar factor of the elementary
71 * reflector H(i), as returned by DSYTRD.
72 *
73 * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
74 * On entry, the M-by-N matrix C.
75 * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
76 *
77 * LDC (input) INTEGER
78 * The leading dimension of the array C. LDC >= max(1,M).
79 *
80 * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
81 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
82 *
83 * LWORK (input) INTEGER
84 * The dimension of the array WORK.
85 * If SIDE = 'L', LWORK >= max(1,N);
86 * if SIDE = 'R', LWORK >= max(1,M).
87 * For optimum performance LWORK >= N*NB if SIDE = 'L', and
88 * LWORK >= M*NB if SIDE = 'R', where NB is the optimal
89 * blocksize.
90 *
91 * If LWORK = -1, then a workspace query is assumed; the routine
92 * only calculates the optimal size of the WORK array, returns
93 * this value as the first entry of the WORK array, and no error
94 * message related to LWORK is issued by XERBLA.
95 *
96 * INFO (output) INTEGER
97 * = 0: successful exit
98 * < 0: if INFO = -i, the i-th argument had an illegal value
99 *
100 * =====================================================================
101 *
102 * .. Local Scalars ..
103 LOGICAL LEFT, LQUERY, UPPER
104 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
105 * ..
106 * .. External Functions ..
107 LOGICAL LSAME
108 INTEGER ILAENV
109 EXTERNAL LSAME, ILAENV
110 * ..
111 * .. External Subroutines ..
112 EXTERNAL DORMQL, DORMQR, XERBLA
113 * ..
114 * .. Intrinsic Functions ..
115 INTRINSIC MAX
116 * ..
117 * .. Executable Statements ..
118 *
119 * Test the input arguments
120 *
121 INFO = 0
122 LEFT = LSAME( SIDE, 'L' )
123 UPPER = LSAME( UPLO, 'U' )
124 LQUERY = ( LWORK.EQ.-1 )
125 *
126 * NQ is the order of Q and NW is the minimum dimension of WORK
127 *
128 IF( LEFT ) THEN
129 NQ = M
130 NW = N
131 ELSE
132 NQ = N
133 NW = M
134 END IF
135 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
136 INFO = -1
137 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
138 INFO = -2
139 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
140 $ THEN
141 INFO = -3
142 ELSE IF( M.LT.0 ) THEN
143 INFO = -4
144 ELSE IF( N.LT.0 ) THEN
145 INFO = -5
146 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
147 INFO = -7
148 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
149 INFO = -10
150 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
151 INFO = -12
152 END IF
153 *
154 IF( INFO.EQ.0 ) THEN
155 IF( UPPER ) THEN
156 IF( LEFT ) THEN
157 NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1,
158 $ -1 )
159 ELSE
160 NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1,
161 $ -1 )
162 END IF
163 ELSE
164 IF( LEFT ) THEN
165 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
166 $ -1 )
167 ELSE
168 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
169 $ -1 )
170 END IF
171 END IF
172 LWKOPT = MAX( 1, NW )*NB
173 WORK( 1 ) = LWKOPT
174 END IF
175 *
176 IF( INFO.NE.0 ) THEN
177 CALL XERBLA( 'DORMTR', -INFO )
178 RETURN
179 ELSE IF( LQUERY ) THEN
180 RETURN
181 END IF
182 *
183 * Quick return if possible
184 *
185 IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
186 WORK( 1 ) = 1
187 RETURN
188 END IF
189 *
190 IF( LEFT ) THEN
191 MI = M - 1
192 NI = N
193 ELSE
194 MI = M
195 NI = N - 1
196 END IF
197 *
198 IF( UPPER ) THEN
199 *
200 * Q was determined by a call to DSYTRD with UPLO = 'U'
201 *
202 CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
203 $ LDC, WORK, LWORK, IINFO )
204 ELSE
205 *
206 * Q was determined by a call to DSYTRD with UPLO = 'L'
207 *
208 IF( LEFT ) THEN
209 I1 = 2
210 I2 = 1
211 ELSE
212 I1 = 1
213 I2 = 2
214 END IF
215 CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
216 $ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
217 END IF
218 WORK( 1 ) = LWKOPT
219 RETURN
220 *
221 * End of DORMTR
222 *
223 END
2 $ WORK, LWORK, INFO )
3 *
4 * -- LAPACK routine (version 3.2) --
5 * -- LAPACK is a software package provided by Univ. of Tennessee, --
6 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7 * November 2006
8 *
9 * .. Scalar Arguments ..
10 CHARACTER SIDE, TRANS, UPLO
11 INTEGER INFO, LDA, LDC, LWORK, M, N
12 * ..
13 * .. Array Arguments ..
14 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
15 * ..
16 *
17 * Purpose
18 * =======
19 *
20 * DORMTR overwrites the general real M-by-N matrix C with
21 *
22 * SIDE = 'L' SIDE = 'R'
23 * TRANS = 'N': Q * C C * Q
24 * TRANS = 'T': Q**T * C C * Q**T
25 *
26 * where Q is a real orthogonal matrix of order nq, with nq = m if
27 * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
28 * nq-1 elementary reflectors, as returned by DSYTRD:
29 *
30 * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
31 *
32 * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
33 *
34 * Arguments
35 * =========
36 *
37 * SIDE (input) CHARACTER*1
38 * = 'L': apply Q or Q**T from the Left;
39 * = 'R': apply Q or Q**T from the Right.
40 *
41 * UPLO (input) CHARACTER*1
42 * = 'U': Upper triangle of A contains elementary reflectors
43 * from DSYTRD;
44 * = 'L': Lower triangle of A contains elementary reflectors
45 * from DSYTRD.
46 *
47 * TRANS (input) CHARACTER*1
48 * = 'N': No transpose, apply Q;
49 * = 'T': Transpose, apply Q**T.
50 *
51 * M (input) INTEGER
52 * The number of rows of the matrix C. M >= 0.
53 *
54 * N (input) INTEGER
55 * The number of columns of the matrix C. N >= 0.
56 *
57 * A (input) DOUBLE PRECISION array, dimension
58 * (LDA,M) if SIDE = 'L'
59 * (LDA,N) if SIDE = 'R'
60 * The vectors which define the elementary reflectors, as
61 * returned by DSYTRD.
62 *
63 * LDA (input) INTEGER
64 * The leading dimension of the array A.
65 * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
66 *
67 * TAU (input) DOUBLE PRECISION array, dimension
68 * (M-1) if SIDE = 'L'
69 * (N-1) if SIDE = 'R'
70 * TAU(i) must contain the scalar factor of the elementary
71 * reflector H(i), as returned by DSYTRD.
72 *
73 * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
74 * On entry, the M-by-N matrix C.
75 * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
76 *
77 * LDC (input) INTEGER
78 * The leading dimension of the array C. LDC >= max(1,M).
79 *
80 * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
81 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
82 *
83 * LWORK (input) INTEGER
84 * The dimension of the array WORK.
85 * If SIDE = 'L', LWORK >= max(1,N);
86 * if SIDE = 'R', LWORK >= max(1,M).
87 * For optimum performance LWORK >= N*NB if SIDE = 'L', and
88 * LWORK >= M*NB if SIDE = 'R', where NB is the optimal
89 * blocksize.
90 *
91 * If LWORK = -1, then a workspace query is assumed; the routine
92 * only calculates the optimal size of the WORK array, returns
93 * this value as the first entry of the WORK array, and no error
94 * message related to LWORK is issued by XERBLA.
95 *
96 * INFO (output) INTEGER
97 * = 0: successful exit
98 * < 0: if INFO = -i, the i-th argument had an illegal value
99 *
100 * =====================================================================
101 *
102 * .. Local Scalars ..
103 LOGICAL LEFT, LQUERY, UPPER
104 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
105 * ..
106 * .. External Functions ..
107 LOGICAL LSAME
108 INTEGER ILAENV
109 EXTERNAL LSAME, ILAENV
110 * ..
111 * .. External Subroutines ..
112 EXTERNAL DORMQL, DORMQR, XERBLA
113 * ..
114 * .. Intrinsic Functions ..
115 INTRINSIC MAX
116 * ..
117 * .. Executable Statements ..
118 *
119 * Test the input arguments
120 *
121 INFO = 0
122 LEFT = LSAME( SIDE, 'L' )
123 UPPER = LSAME( UPLO, 'U' )
124 LQUERY = ( LWORK.EQ.-1 )
125 *
126 * NQ is the order of Q and NW is the minimum dimension of WORK
127 *
128 IF( LEFT ) THEN
129 NQ = M
130 NW = N
131 ELSE
132 NQ = N
133 NW = M
134 END IF
135 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
136 INFO = -1
137 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
138 INFO = -2
139 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
140 $ THEN
141 INFO = -3
142 ELSE IF( M.LT.0 ) THEN
143 INFO = -4
144 ELSE IF( N.LT.0 ) THEN
145 INFO = -5
146 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
147 INFO = -7
148 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
149 INFO = -10
150 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
151 INFO = -12
152 END IF
153 *
154 IF( INFO.EQ.0 ) THEN
155 IF( UPPER ) THEN
156 IF( LEFT ) THEN
157 NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1,
158 $ -1 )
159 ELSE
160 NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1,
161 $ -1 )
162 END IF
163 ELSE
164 IF( LEFT ) THEN
165 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
166 $ -1 )
167 ELSE
168 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
169 $ -1 )
170 END IF
171 END IF
172 LWKOPT = MAX( 1, NW )*NB
173 WORK( 1 ) = LWKOPT
174 END IF
175 *
176 IF( INFO.NE.0 ) THEN
177 CALL XERBLA( 'DORMTR', -INFO )
178 RETURN
179 ELSE IF( LQUERY ) THEN
180 RETURN
181 END IF
182 *
183 * Quick return if possible
184 *
185 IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
186 WORK( 1 ) = 1
187 RETURN
188 END IF
189 *
190 IF( LEFT ) THEN
191 MI = M - 1
192 NI = N
193 ELSE
194 MI = M
195 NI = N - 1
196 END IF
197 *
198 IF( UPPER ) THEN
199 *
200 * Q was determined by a call to DSYTRD with UPLO = 'U'
201 *
202 CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
203 $ LDC, WORK, LWORK, IINFO )
204 ELSE
205 *
206 * Q was determined by a call to DSYTRD with UPLO = 'L'
207 *
208 IF( LEFT ) THEN
209 I1 = 2
210 I2 = 1
211 ELSE
212 I1 = 1
213 I2 = 2
214 END IF
215 CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
216 $ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
217 END IF
218 WORK( 1 ) = LWKOPT
219 RETURN
220 *
221 * End of DORMTR
222 *
223 END