001:       SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )
002: *
003: *  -- LAPACK auxiliary 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, LDA, N
011: *     ..
012: *     .. Array Arguments ..
013:       COMPLEX*16         A( LDA, * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  ZLAUUM computes the product U * U' or L' * L, where the triangular
020: *  factor U or L is stored in the upper or lower triangular part of
021: *  the array A.
022: *
023: *  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
024: *  overwriting the factor U in A.
025: *  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
026: *  overwriting the factor L in A.
027: *
028: *  This is the blocked form of the algorithm, calling Level 3 BLAS.
029: *
030: *  Arguments
031: *  =========
032: *
033: *  UPLO    (input) CHARACTER*1
034: *          Specifies whether the triangular factor stored in the array A
035: *          is upper or lower triangular:
036: *          = 'U':  Upper triangular
037: *          = 'L':  Lower triangular
038: *
039: *  N       (input) INTEGER
040: *          The order of the triangular factor U or L.  N >= 0.
041: *
042: *  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
043: *          On entry, the triangular factor U or L.
044: *          On exit, if UPLO = 'U', the upper triangle of A is
045: *          overwritten with the upper triangle of the product U * U';
046: *          if UPLO = 'L', the lower triangle of A is overwritten with
047: *          the lower triangle of the product L' * L.
048: *
049: *  LDA     (input) INTEGER
050: *          The leading dimension of the array A.  LDA >= max(1,N).
051: *
052: *  INFO    (output) INTEGER
053: *          = 0: successful exit
054: *          < 0: if INFO = -k, the k-th argument had an illegal value
055: *
056: *  =====================================================================
057: *
058: *     .. Parameters ..
059:       DOUBLE PRECISION   ONE
060:       PARAMETER          ( ONE = 1.0D+0 )
061:       COMPLEX*16         CONE
062:       PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
063: *     ..
064: *     .. Local Scalars ..
065:       LOGICAL            UPPER
066:       INTEGER            I, IB, NB
067: *     ..
068: *     .. External Functions ..
069:       LOGICAL            LSAME
070:       INTEGER            ILAENV
071:       EXTERNAL           LSAME, ILAENV
072: *     ..
073: *     .. External Subroutines ..
074:       EXTERNAL           XERBLA, ZGEMM, ZHERK, ZLAUU2, ZTRMM
075: *     ..
076: *     .. Intrinsic Functions ..
077:       INTRINSIC          MAX, MIN
078: *     ..
079: *     .. Executable Statements ..
080: *
081: *     Test the input parameters.
082: *
083:       INFO = 0
084:       UPPER = LSAME( UPLO, 'U' )
085:       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
086:          INFO = -1
087:       ELSE IF( N.LT.0 ) THEN
088:          INFO = -2
089:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
090:          INFO = -4
091:       END IF
092:       IF( INFO.NE.0 ) THEN
093:          CALL XERBLA( 'ZLAUUM', -INFO )
094:          RETURN
095:       END IF
096: *
097: *     Quick return if possible
098: *
099:       IF( N.EQ.0 )
100:      $   RETURN
101: *
102: *     Determine the block size for this environment.
103: *
104:       NB = ILAENV( 1, 'ZLAUUM', UPLO, N, -1, -1, -1 )
105: *
106:       IF( NB.LE.1 .OR. NB.GE.N ) THEN
107: *
108: *        Use unblocked code
109: *
110:          CALL ZLAUU2( UPLO, N, A, LDA, INFO )
111:       ELSE
112: *
113: *        Use blocked code
114: *
115:          IF( UPPER ) THEN
116: *
117: *           Compute the product U * U'.
118: *
119:             DO 10 I = 1, N, NB
120:                IB = MIN( NB, N-I+1 )
121:                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
122:      $                     'Non-unit', I-1, IB, CONE, A( I, I ), LDA,
123:      $                     A( 1, I ), LDA )
124:                CALL ZLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
125:                IF( I+IB.LE.N ) THEN
126:                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
127:      $                        I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ),
128:      $                        LDA, A( I, I+IB ), LDA, CONE, A( 1, I ),
129:      $                        LDA )
130:                   CALL ZHERK( 'Upper', 'No transpose', IB, N-I-IB+1,
131:      $                        ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
132:      $                        LDA )
133:                END IF
134:    10       CONTINUE
135:          ELSE
136: *
137: *           Compute the product L' * L.
138: *
139:             DO 20 I = 1, N, NB
140:                IB = MIN( NB, N-I+1 )
141:                CALL ZTRMM( 'Left', 'Lower', 'Conjugate transpose',
142:      $                     'Non-unit', IB, I-1, CONE, A( I, I ), LDA,
143:      $                     A( I, 1 ), LDA )
144:                CALL ZLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
145:                IF( I+IB.LE.N ) THEN
146:                   CALL ZGEMM( 'Conjugate transpose', 'No transpose', IB,
147:      $                        I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA,
148:      $                        A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA )
149:                   CALL ZHERK( 'Lower', 'Conjugate transpose', IB,
150:      $                        N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE,
151:      $                        A( I, I ), LDA )
152:                END IF
153:    20       CONTINUE
154:          END IF
155:       END IF
156: *
157:       RETURN
158: *
159: *     End of ZLAUUM
160: *
161:       END
162: