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