1*> \brief \b SOPGTR
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download SOPGTR + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sopgtr.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sopgtr.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sopgtr.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
22*
23*       .. Scalar Arguments ..
24*       CHARACTER          UPLO
25*       INTEGER            INFO, LDQ, N
26*       ..
27*       .. Array Arguments ..
28*       REAL               AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
29*       ..
30*
31*
32*> \par Purpose:
33*  =============
34*>
35*> \verbatim
36*>
37*> SOPGTR generates a real orthogonal matrix Q which is defined as the
38*> product of n-1 elementary reflectors H(i) of order n, as returned by
39*> SSPTRD using packed storage:
40*>
41*> if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
42*>
43*> if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
44*> \endverbatim
45*
46*  Arguments:
47*  ==========
48*
49*> \param[in] UPLO
50*> \verbatim
51*>          UPLO is CHARACTER*1
52*>          = 'U': Upper triangular packed storage used in previous
53*>                 call to SSPTRD;
54*>          = 'L': Lower triangular packed storage used in previous
55*>                 call to SSPTRD.
56*> \endverbatim
57*>
58*> \param[in] N
59*> \verbatim
60*>          N is INTEGER
61*>          The order of the matrix Q. N >= 0.
62*> \endverbatim
63*>
64*> \param[in] AP
65*> \verbatim
66*>          AP is REAL array, dimension (N*(N+1)/2)
67*>          The vectors which define the elementary reflectors, as
68*>          returned by SSPTRD.
69*> \endverbatim
70*>
71*> \param[in] TAU
72*> \verbatim
73*>          TAU is REAL array, dimension (N-1)
74*>          TAU(i) must contain the scalar factor of the elementary
75*>          reflector H(i), as returned by SSPTRD.
76*> \endverbatim
77*>
78*> \param[out] Q
79*> \verbatim
80*>          Q is REAL array, dimension (LDQ,N)
81*>          The N-by-N orthogonal matrix Q.
82*> \endverbatim
83*>
84*> \param[in] LDQ
85*> \verbatim
86*>          LDQ is INTEGER
87*>          The leading dimension of the array Q. LDQ >= max(1,N).
88*> \endverbatim
89*>
90*> \param[out] WORK
91*> \verbatim
92*>          WORK is REAL array, dimension (N-1)
93*> \endverbatim
94*>
95*> \param[out] INFO
96*> \verbatim
97*>          INFO is INTEGER
98*>          = 0:  successful exit
99*>          < 0:  if INFO = -i, the i-th argument had an illegal value
100*> \endverbatim
101*
102*  Authors:
103*  ========
104*
105*> \author Univ. of Tennessee
106*> \author Univ. of California Berkeley
107*> \author Univ. of Colorado Denver
108*> \author NAG Ltd.
109*
110*> \date November 2011
111*
112*> \ingroup realOTHERcomputational
113*
114*  =====================================================================
115      SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
116*
117*  -- LAPACK computational routine (version 3.4.0) --
118*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
119*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
120*     November 2011
121*
122*     .. Scalar Arguments ..
123      CHARACTER          UPLO
124      INTEGER            INFO, LDQ, N
125*     ..
126*     .. Array Arguments ..
127      REAL               AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
128*     ..
129*
130*  =====================================================================
131*
132*     .. Parameters ..
133      REAL               ZERO, ONE
134      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
135*     ..
136*     .. Local Scalars ..
137      LOGICAL            UPPER
138      INTEGER            I, IINFO, IJ, J
139*     ..
140*     .. External Functions ..
141      LOGICAL            LSAME
142      EXTERNAL           LSAME
143*     ..
144*     .. External Subroutines ..
145      EXTERNAL           SORG2L, SORG2R, XERBLA
146*     ..
147*     .. Intrinsic Functions ..
148      INTRINSIC          MAX
149*     ..
150*     .. Executable Statements ..
151*
152*     Test the input arguments
153*
154      INFO = 0
155      UPPER = LSAME( UPLO, 'U' )
156      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
157         INFO = -1
158      ELSE IF( N.LT.0 ) THEN
159         INFO = -2
160      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
161         INFO = -6
162      END IF
163      IF( INFO.NE.0 ) THEN
164         CALL XERBLA( 'SOPGTR', -INFO )
165         RETURN
166      END IF
167*
168*     Quick return if possible
169*
170      IF( N.EQ.0 )
171     $   RETURN
172*
173      IF( UPPER ) THEN
174*
175*        Q was determined by a call to SSPTRD with UPLO = 'U'
176*
177*        Unpack the vectors which define the elementary reflectors and
178*        set the last row and column of Q equal to those of the unit
179*        matrix
180*
181         IJ = 2
182         DO 20 J = 1, N - 1
183            DO 10 I = 1, J - 1
184               Q( I, J ) = AP( IJ )
185               IJ = IJ + 1
186   10       CONTINUE
187            IJ = IJ + 2
188            Q( N, J ) = ZERO
189   20    CONTINUE
190         DO 30 I = 1, N - 1
191            Q( I, N ) = ZERO
192   30    CONTINUE
193         Q( N, N ) = ONE
194*
195*        Generate Q(1:n-1,1:n-1)
196*
197         CALL SORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
198*
199      ELSE
200*
201*        Q was determined by a call to SSPTRD with UPLO = 'L'.
202*
203*        Unpack the vectors which define the elementary reflectors and
204*        set the first row and column of Q equal to those of the unit
205*        matrix
206*
207         Q( 1, 1 ) = ONE
208         DO 40 I = 2, N
209            Q( I, 1 ) = ZERO
210   40    CONTINUE
211         IJ = 3
212         DO 60 J = 2, N
213            Q( 1, J ) = ZERO
214            DO 50 I = J + 1, N
215               Q( I, J ) = AP( IJ )
216               IJ = IJ + 1
217   50       CONTINUE
218            IJ = IJ + 2
219   60    CONTINUE
220         IF( N.GT.1 ) THEN
221*
222*           Generate Q(2:n,2:n)
223*
224            CALL SORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
225     $                   IINFO )
226         END IF
227      END IF
228      RETURN
229*
230*     End of SOPGTR
231*
232      END
233