1 SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, 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 CHARACTER UPLO
10 INTEGER INFO, LDQ, N
11 * ..
12 * .. Array Arguments ..
13 DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
14 * ..
15 *
16 * Purpose
17 * =======
18 *
19 * DOPGTR generates a real orthogonal matrix Q which is defined as the
20 * product of n-1 elementary reflectors H(i) of order n, as returned by
21 * DSPTRD using packed storage:
22 *
23 * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
24 *
25 * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
26 *
27 * Arguments
28 * =========
29 *
30 * UPLO (input) CHARACTER*1
31 * = 'U': Upper triangular packed storage used in previous
32 * call to DSPTRD;
33 * = 'L': Lower triangular packed storage used in previous
34 * call to DSPTRD.
35 *
36 * N (input) INTEGER
37 * The order of the matrix Q. N >= 0.
38 *
39 * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
40 * The vectors which define the elementary reflectors, as
41 * returned by DSPTRD.
42 *
43 * TAU (input) DOUBLE PRECISION array, dimension (N-1)
44 * TAU(i) must contain the scalar factor of the elementary
45 * reflector H(i), as returned by DSPTRD.
46 *
47 * Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
48 * The N-by-N orthogonal matrix Q.
49 *
50 * LDQ (input) INTEGER
51 * The leading dimension of the array Q. LDQ >= max(1,N).
52 *
53 * WORK (workspace) DOUBLE PRECISION array, dimension (N-1)
54 *
55 * INFO (output) INTEGER
56 * = 0: successful exit
57 * < 0: if INFO = -i, the i-th argument had an illegal value
58 *
59 * =====================================================================
60 *
61 * .. Parameters ..
62 DOUBLE PRECISION ZERO, ONE
63 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
64 * ..
65 * .. Local Scalars ..
66 LOGICAL UPPER
67 INTEGER I, IINFO, IJ, J
68 * ..
69 * .. External Functions ..
70 LOGICAL LSAME
71 EXTERNAL LSAME
72 * ..
73 * .. External Subroutines ..
74 EXTERNAL DORG2L, DORG2R, XERBLA
75 * ..
76 * .. Intrinsic Functions ..
77 INTRINSIC MAX
78 * ..
79 * .. Executable Statements ..
80 *
81 * Test the input arguments
82 *
83 INFO = 0
84 UPPER = LSAME( UPLO, 'U' )
85 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
86 INFO = -1
87 ELSE IF( N.LT.0 ) THEN
88 INFO = -2
89 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
90 INFO = -6
91 END IF
92 IF( INFO.NE.0 ) THEN
93 CALL XERBLA( 'DOPGTR', -INFO )
94 RETURN
95 END IF
96 *
97 * Quick return if possible
98 *
99 IF( N.EQ.0 )
100 $ RETURN
101 *
102 IF( UPPER ) THEN
103 *
104 * Q was determined by a call to DSPTRD with UPLO = 'U'
105 *
106 * Unpack the vectors which define the elementary reflectors and
107 * set the last row and column of Q equal to those of the unit
108 * matrix
109 *
110 IJ = 2
111 DO 20 J = 1, N - 1
112 DO 10 I = 1, J - 1
113 Q( I, J ) = AP( IJ )
114 IJ = IJ + 1
115 10 CONTINUE
116 IJ = IJ + 2
117 Q( N, J ) = ZERO
118 20 CONTINUE
119 DO 30 I = 1, N - 1
120 Q( I, N ) = ZERO
121 30 CONTINUE
122 Q( N, N ) = ONE
123 *
124 * Generate Q(1:n-1,1:n-1)
125 *
126 CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
127 *
128 ELSE
129 *
130 * Q was determined by a call to DSPTRD with UPLO = 'L'.
131 *
132 * Unpack the vectors which define the elementary reflectors and
133 * set the first row and column of Q equal to those of the unit
134 * matrix
135 *
136 Q( 1, 1 ) = ONE
137 DO 40 I = 2, N
138 Q( I, 1 ) = ZERO
139 40 CONTINUE
140 IJ = 3
141 DO 60 J = 2, N
142 Q( 1, J ) = ZERO
143 DO 50 I = J + 1, N
144 Q( I, J ) = AP( IJ )
145 IJ = IJ + 1
146 50 CONTINUE
147 IJ = IJ + 2
148 60 CONTINUE
149 IF( N.GT.1 ) THEN
150 *
151 * Generate Q(2:n,2:n)
152 *
153 CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
154 $ IINFO )
155 END IF
156 END IF
157 RETURN
158 *
159 * End of DOPGTR
160 *
161 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 CHARACTER UPLO
10 INTEGER INFO, LDQ, N
11 * ..
12 * .. Array Arguments ..
13 DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
14 * ..
15 *
16 * Purpose
17 * =======
18 *
19 * DOPGTR generates a real orthogonal matrix Q which is defined as the
20 * product of n-1 elementary reflectors H(i) of order n, as returned by
21 * DSPTRD using packed storage:
22 *
23 * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
24 *
25 * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
26 *
27 * Arguments
28 * =========
29 *
30 * UPLO (input) CHARACTER*1
31 * = 'U': Upper triangular packed storage used in previous
32 * call to DSPTRD;
33 * = 'L': Lower triangular packed storage used in previous
34 * call to DSPTRD.
35 *
36 * N (input) INTEGER
37 * The order of the matrix Q. N >= 0.
38 *
39 * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
40 * The vectors which define the elementary reflectors, as
41 * returned by DSPTRD.
42 *
43 * TAU (input) DOUBLE PRECISION array, dimension (N-1)
44 * TAU(i) must contain the scalar factor of the elementary
45 * reflector H(i), as returned by DSPTRD.
46 *
47 * Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
48 * The N-by-N orthogonal matrix Q.
49 *
50 * LDQ (input) INTEGER
51 * The leading dimension of the array Q. LDQ >= max(1,N).
52 *
53 * WORK (workspace) DOUBLE PRECISION array, dimension (N-1)
54 *
55 * INFO (output) INTEGER
56 * = 0: successful exit
57 * < 0: if INFO = -i, the i-th argument had an illegal value
58 *
59 * =====================================================================
60 *
61 * .. Parameters ..
62 DOUBLE PRECISION ZERO, ONE
63 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
64 * ..
65 * .. Local Scalars ..
66 LOGICAL UPPER
67 INTEGER I, IINFO, IJ, J
68 * ..
69 * .. External Functions ..
70 LOGICAL LSAME
71 EXTERNAL LSAME
72 * ..
73 * .. External Subroutines ..
74 EXTERNAL DORG2L, DORG2R, XERBLA
75 * ..
76 * .. Intrinsic Functions ..
77 INTRINSIC MAX
78 * ..
79 * .. Executable Statements ..
80 *
81 * Test the input arguments
82 *
83 INFO = 0
84 UPPER = LSAME( UPLO, 'U' )
85 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
86 INFO = -1
87 ELSE IF( N.LT.0 ) THEN
88 INFO = -2
89 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
90 INFO = -6
91 END IF
92 IF( INFO.NE.0 ) THEN
93 CALL XERBLA( 'DOPGTR', -INFO )
94 RETURN
95 END IF
96 *
97 * Quick return if possible
98 *
99 IF( N.EQ.0 )
100 $ RETURN
101 *
102 IF( UPPER ) THEN
103 *
104 * Q was determined by a call to DSPTRD with UPLO = 'U'
105 *
106 * Unpack the vectors which define the elementary reflectors and
107 * set the last row and column of Q equal to those of the unit
108 * matrix
109 *
110 IJ = 2
111 DO 20 J = 1, N - 1
112 DO 10 I = 1, J - 1
113 Q( I, J ) = AP( IJ )
114 IJ = IJ + 1
115 10 CONTINUE
116 IJ = IJ + 2
117 Q( N, J ) = ZERO
118 20 CONTINUE
119 DO 30 I = 1, N - 1
120 Q( I, N ) = ZERO
121 30 CONTINUE
122 Q( N, N ) = ONE
123 *
124 * Generate Q(1:n-1,1:n-1)
125 *
126 CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
127 *
128 ELSE
129 *
130 * Q was determined by a call to DSPTRD with UPLO = 'L'.
131 *
132 * Unpack the vectors which define the elementary reflectors and
133 * set the first row and column of Q equal to those of the unit
134 * matrix
135 *
136 Q( 1, 1 ) = ONE
137 DO 40 I = 2, N
138 Q( I, 1 ) = ZERO
139 40 CONTINUE
140 IJ = 3
141 DO 60 J = 2, N
142 Q( 1, J ) = ZERO
143 DO 50 I = J + 1, N
144 Q( I, J ) = AP( IJ )
145 IJ = IJ + 1
146 50 CONTINUE
147 IJ = IJ + 2
148 60 CONTINUE
149 IF( N.GT.1 ) THEN
150 *
151 * Generate Q(2:n,2:n)
152 *
153 CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
154 $ IINFO )
155 END IF
156 END IF
157 RETURN
158 *
159 * End of DOPGTR
160 *
161 END