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