```001:       SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, 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, LDA, N
010: *     ..
011: *     .. Array Arguments ..
012:       REAL               D( * ), E( * )
013:       COMPLEX            A( LDA, * ), TAU( * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  CHETD2 reduces a complex Hermitian matrix A to real symmetric
020: *  tridiagonal form T by a unitary similarity transformation:
021: *  Q' * A * Q = T.
022: *
023: *  Arguments
024: *  =========
025: *
026: *  UPLO    (input) CHARACTER*1
027: *          Specifies whether the upper or lower triangular part of the
028: *          Hermitian matrix A is stored:
029: *          = 'U':  Upper triangular
030: *          = 'L':  Lower triangular
031: *
032: *  N       (input) INTEGER
033: *          The order of the matrix A.  N >= 0.
034: *
035: *  A       (input/output) COMPLEX array, dimension (LDA,N)
036: *          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
037: *          n-by-n upper triangular part of A contains the upper
038: *          triangular part of the matrix A, and the strictly lower
039: *          triangular part of A is not referenced.  If UPLO = 'L', the
040: *          leading n-by-n lower triangular part of A contains the lower
041: *          triangular part of the matrix A, and the strictly upper
042: *          triangular part of A is not referenced.
043: *          On exit, if UPLO = 'U', the diagonal and first superdiagonal
044: *          of A are overwritten by the corresponding elements of the
045: *          tridiagonal matrix T, and the elements above the first
046: *          superdiagonal, with the array TAU, represent the unitary
047: *          matrix Q as a product of elementary reflectors; if UPLO
048: *          = 'L', the diagonal and first subdiagonal of A are over-
049: *          written by the corresponding elements of the tridiagonal
050: *          matrix T, and the elements below the first subdiagonal, with
051: *          the array TAU, represent the unitary matrix Q as a product
052: *          of elementary reflectors. See Further Details.
053: *
054: *  LDA     (input) INTEGER
055: *          The leading dimension of the array A.  LDA >= max(1,N).
056: *
057: *  D       (output) REAL array, dimension (N)
058: *          The diagonal elements of the tridiagonal matrix T:
059: *          D(i) = A(i,i).
060: *
061: *  E       (output) REAL array, dimension (N-1)
062: *          The off-diagonal elements of the tridiagonal matrix T:
063: *          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
064: *
065: *  TAU     (output) COMPLEX array, dimension (N-1)
066: *          The scalar factors of the elementary reflectors (see Further
067: *          Details).
068: *
069: *  INFO    (output) INTEGER
070: *          = 0:  successful exit
071: *          < 0:  if INFO = -i, the i-th argument had an illegal value.
072: *
073: *  Further Details
074: *  ===============
075: *
076: *  If UPLO = 'U', the matrix Q is represented as a product of elementary
077: *  reflectors
078: *
079: *     Q = H(n-1) . . . H(2) H(1).
080: *
081: *  Each H(i) has the form
082: *
083: *     H(i) = I - tau * v * v'
084: *
085: *  where tau is a complex scalar, and v is a complex vector with
086: *  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
087: *  A(1:i-1,i+1), and tau in TAU(i).
088: *
089: *  If UPLO = 'L', the matrix Q is represented as a product of elementary
090: *  reflectors
091: *
092: *     Q = H(1) H(2) . . . H(n-1).
093: *
094: *  Each H(i) has the form
095: *
096: *     H(i) = I - tau * v * v'
097: *
098: *  where tau is a complex scalar, and v is a complex vector with
099: *  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
100: *  and tau in TAU(i).
101: *
102: *  The contents of A on exit are illustrated by the following examples
103: *  with n = 5:
104: *
105: *  if UPLO = 'U':                       if UPLO = 'L':
106: *
107: *    (  d   e   v2  v3  v4 )              (  d                  )
108: *    (      d   e   v3  v4 )              (  e   d              )
109: *    (          d   e   v4 )              (  v1  e   d          )
110: *    (              d   e  )              (  v1  v2  e   d      )
111: *    (                  d  )              (  v1  v2  v3  e   d  )
112: *
113: *  where d and e denote diagonal and off-diagonal elements of T, and vi
114: *  denotes an element of the vector defining H(i).
115: *
116: *  =====================================================================
117: *
118: *     .. Parameters ..
119:       COMPLEX            ONE, ZERO, HALF
120:       PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
121:      \$                   ZERO = ( 0.0E+0, 0.0E+0 ),
122:      \$                   HALF = ( 0.5E+0, 0.0E+0 ) )
123: *     ..
124: *     .. Local Scalars ..
125:       LOGICAL            UPPER
126:       INTEGER            I
127:       COMPLEX            ALPHA, TAUI
128: *     ..
129: *     .. External Subroutines ..
130:       EXTERNAL           CAXPY, CHEMV, CHER2, CLARFG, XERBLA
131: *     ..
132: *     .. External Functions ..
133:       LOGICAL            LSAME
134:       COMPLEX            CDOTC
135:       EXTERNAL           LSAME, CDOTC
136: *     ..
137: *     .. Intrinsic Functions ..
138:       INTRINSIC          MAX, MIN, REAL
139: *     ..
140: *     .. Executable Statements ..
141: *
142: *     Test the input parameters
143: *
144:       INFO = 0
145:       UPPER = LSAME( UPLO, 'U' )
146:       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
147:          INFO = -1
148:       ELSE IF( N.LT.0 ) THEN
149:          INFO = -2
150:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
151:          INFO = -4
152:       END IF
153:       IF( INFO.NE.0 ) THEN
154:          CALL XERBLA( 'CHETD2', -INFO )
155:          RETURN
156:       END IF
157: *
158: *     Quick return if possible
159: *
160:       IF( N.LE.0 )
161:      \$   RETURN
162: *
163:       IF( UPPER ) THEN
164: *
165: *        Reduce the upper triangle of A
166: *
167:          A( N, N ) = REAL( A( N, N ) )
168:          DO 10 I = N - 1, 1, -1
169: *
170: *           Generate elementary reflector H(i) = I - tau * v * v'
171: *           to annihilate A(1:i-1,i+1)
172: *
173:             ALPHA = A( I, I+1 )
174:             CALL CLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI )
175:             E( I ) = ALPHA
176: *
177:             IF( TAUI.NE.ZERO ) THEN
178: *
179: *              Apply H(i) from both sides to A(1:i,1:i)
180: *
181:                A( I, I+1 ) = ONE
182: *
183: *              Compute  x := tau * A * v  storing x in TAU(1:i)
184: *
185:                CALL CHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
186:      \$                     TAU, 1 )
187: *
188: *              Compute  w := x - 1/2 * tau * (x'*v) * v
189: *
190:                ALPHA = -HALF*TAUI*CDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
191:                CALL CAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
192: *
193: *              Apply the transformation as a rank-2 update:
194: *                 A := A - v * w' - w * v'
195: *
196:                CALL CHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
197:      \$                     LDA )
198: *
199:             ELSE
200:                A( I, I ) = REAL( A( I, I ) )
201:             END IF
202:             A( I, I+1 ) = E( I )
203:             D( I+1 ) = A( I+1, I+1 )
204:             TAU( I ) = TAUI
205:    10    CONTINUE
206:          D( 1 ) = A( 1, 1 )
207:       ELSE
208: *
209: *        Reduce the lower triangle of A
210: *
211:          A( 1, 1 ) = REAL( A( 1, 1 ) )
212:          DO 20 I = 1, N - 1
213: *
214: *           Generate elementary reflector H(i) = I - tau * v * v'
215: *           to annihilate A(i+2:n,i)
216: *
217:             ALPHA = A( I+1, I )
218:             CALL CLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI )
219:             E( I ) = ALPHA
220: *
221:             IF( TAUI.NE.ZERO ) THEN
222: *
223: *              Apply H(i) from both sides to A(i+1:n,i+1:n)
224: *
225:                A( I+1, I ) = ONE
226: *
227: *              Compute  x := tau * A * v  storing y in TAU(i:n-1)
228: *
229:                CALL CHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
230:      \$                     A( I+1, I ), 1, ZERO, TAU( I ), 1 )
231: *
232: *              Compute  w := x - 1/2 * tau * (x'*v) * v
233: *
234:                ALPHA = -HALF*TAUI*CDOTC( N-I, TAU( I ), 1, A( I+1, I ),
235:      \$                 1 )
236:                CALL CAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
237: *
238: *              Apply the transformation as a rank-2 update:
239: *                 A := A - v * w' - w * v'
240: *
241:                CALL CHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
242:      \$                     A( I+1, I+1 ), LDA )
243: *
244:             ELSE
245:                A( I+1, I+1 ) = REAL( A( I+1, I+1 ) )
246:             END IF
247:             A( I+1, I ) = E( I )
248:             D( I ) = A( I, I )
249:             TAU( I ) = TAUI
250:    20    CONTINUE
251:          D( N ) = A( N, N )
252:       END IF
253: *
254:       RETURN
255: *
256: *     End of CHETD2
257: *
258:       END
259: ```