001:       SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
002: *
003: *  -- LAPACK routine (version 3.2) --
004: *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
005: *     November 2006
006: *
007: *     .. Scalar Arguments ..
008:       CHARACTER          UPLO
009:       INTEGER            INFO, LDQ, N
010: *     ..
011: *     .. Array Arguments ..
012:       REAL               AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
013: *     ..
014: *
015: *  Purpose
016: *  =======
017: *
018: *  SOPGTR generates a real orthogonal matrix Q which is defined as the
019: *  product of n-1 elementary reflectors H(i) of order n, as returned by
020: *  SSPTRD using packed storage:
021: *
022: *  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
023: *
024: *  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
025: *
026: *  Arguments
027: *  =========
028: *
029: *  UPLO    (input) CHARACTER*1
030: *          = 'U': Upper triangular packed storage used in previous
031: *                 call to SSPTRD;
032: *          = 'L': Lower triangular packed storage used in previous
033: *                 call to SSPTRD.
034: *
035: *  N       (input) INTEGER
036: *          The order of the matrix Q. N >= 0.
037: *
038: *  AP      (input) REAL array, dimension (N*(N+1)/2)
039: *          The vectors which define the elementary reflectors, as
040: *          returned by SSPTRD.
041: *
042: *  TAU     (input) REAL array, dimension (N-1)
043: *          TAU(i) must contain the scalar factor of the elementary
044: *          reflector H(i), as returned by SSPTRD.
045: *
046: *  Q       (output) REAL array, dimension (LDQ,N)
047: *          The N-by-N orthogonal matrix Q.
048: *
049: *  LDQ     (input) INTEGER
050: *          The leading dimension of the array Q. LDQ >= max(1,N).
051: *
052: *  WORK    (workspace) REAL array, dimension (N-1)
053: *
054: *  INFO    (output) INTEGER
055: *          = 0:  successful exit
056: *          < 0:  if INFO = -i, the i-th argument had an illegal value
057: *
058: *  =====================================================================
059: *
060: *     .. Parameters ..
061:       REAL               ZERO, ONE
062:       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
063: *     ..
064: *     .. Local Scalars ..
065:       LOGICAL            UPPER
066:       INTEGER            I, IINFO, IJ, J
067: *     ..
068: *     .. External Functions ..
069:       LOGICAL            LSAME
070:       EXTERNAL           LSAME
071: *     ..
072: *     .. External Subroutines ..
073:       EXTERNAL           SORG2L, SORG2R, XERBLA
074: *     ..
075: *     .. Intrinsic Functions ..
076:       INTRINSIC          MAX
077: *     ..
078: *     .. Executable Statements ..
079: *
080: *     Test the input arguments
081: *
082:       INFO = 0
083:       UPPER = LSAME( UPLO, 'U' )
084:       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
085:          INFO = -1
086:       ELSE IF( N.LT.0 ) THEN
087:          INFO = -2
088:       ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
089:          INFO = -6
090:       END IF
091:       IF( INFO.NE.0 ) THEN
092:          CALL XERBLA( 'SOPGTR', -INFO )
093:          RETURN
094:       END IF
095: *
096: *     Quick return if possible
097: *
098:       IF( N.EQ.0 )
099:      $   RETURN
100: *
101:       IF( UPPER ) THEN
102: *
103: *        Q was determined by a call to SSPTRD with UPLO = 'U'
104: *
105: *        Unpack the vectors which define the elementary reflectors and
106: *        set the last row and column of Q equal to those of the unit
107: *        matrix
108: *
109:          IJ = 2
110:          DO 20 J = 1, N - 1
111:             DO 10 I = 1, J - 1
112:                Q( I, J ) = AP( IJ )
113:                IJ = IJ + 1
114:    10       CONTINUE
115:             IJ = IJ + 2
116:             Q( N, J ) = ZERO
117:    20    CONTINUE
118:          DO 30 I = 1, N - 1
119:             Q( I, N ) = ZERO
120:    30    CONTINUE
121:          Q( N, N ) = ONE
122: *
123: *        Generate Q(1:n-1,1:n-1)
124: *
125:          CALL SORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
126: *
127:       ELSE
128: *
129: *        Q was determined by a call to SSPTRD with UPLO = 'L'.
130: *
131: *        Unpack the vectors which define the elementary reflectors and
132: *        set the first row and column of Q equal to those of the unit
133: *        matrix
134: *
135:          Q( 1, 1 ) = ONE
136:          DO 40 I = 2, N
137:             Q( I, 1 ) = ZERO
138:    40    CONTINUE
139:          IJ = 3
140:          DO 60 J = 2, N
141:             Q( 1, J ) = ZERO
142:             DO 50 I = J + 1, N
143:                Q( I, J ) = AP( IJ )
144:                IJ = IJ + 1
145:    50       CONTINUE
146:             IJ = IJ + 2
147:    60    CONTINUE
148:          IF( N.GT.1 ) THEN
149: *
150: *           Generate Q(2:n,2:n)
151: *
152:             CALL SORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
153:      $                   IINFO )
154:          END IF
155:       END IF
156:       RETURN
157: *
158: *     End of SOPGTR
159: *
160:       END
161: