SRC/clauum.f

   1 *> \brief \b CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm).
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download CLAUUM + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clauum.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clauum.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clauum.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       CHARACTER          UPLO
  25 *       INTEGER            INFO, LDA, N
  26 *       ..
  27 *       .. Array Arguments ..
  28 *       COMPLEX            A( LDA, * )
  29 *       ..
  30 *
  31 *
  32 *> \par Purpose:
  33 *  =============
  34 *>
  35 *> \verbatim
  36 *>
  37 *> CLAUUM computes the product U * U**H or L**H * L, where the triangular
  38 *> factor U or L is stored in the upper or lower triangular part of
  39 *> the array A.
  40 *>
  41 *> If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
  42 *> overwriting the factor U in A.
  43 *> If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
  44 *> overwriting the factor L in A.
  45 *>
  46 *> This is the blocked form of the algorithm, calling Level 3 BLAS.
  47 *> \endverbatim
  48 *
  49 *  Arguments:
  50 *  ==========
  51 *
  52 *> \param[in] UPLO
  53 *> \verbatim
  54 *>          UPLO is CHARACTER*1
  55 *>          Specifies whether the triangular factor stored in the array A
  56 *>          is upper or lower triangular:
  57 *>          = 'U':  Upper triangular
  58 *>          = 'L':  Lower triangular
  59 *> \endverbatim
  60 *>
  61 *> \param[in] N
  62 *> \verbatim
  63 *>          N is INTEGER
  64 *>          The order of the triangular factor U or L.  N >= 0.
  65 *> \endverbatim
  66 *>
  67 *> \param[in,out] A
  68 *> \verbatim
  69 *>          A is COMPLEX array, dimension (LDA,N)
  70 *>          On entry, the triangular factor U or L.
  71 *>          On exit, if UPLO = 'U', the upper triangle of A is
  72 *>          overwritten with the upper triangle of the product U * U**H;
  73 *>          if UPLO = 'L', the lower triangle of A is overwritten with
  74 *>          the lower triangle of the product L**H * L.
  75 *> \endverbatim
  76 *>
  77 *> \param[in] LDA
  78 *> \verbatim
  79 *>          LDA is INTEGER
  80 *>          The leading dimension of the array A.  LDA >= max(1,N).
  81 *> \endverbatim
  82 *>
  83 *> \param[out] INFO
  84 *> \verbatim
  85 *>          INFO is INTEGER
  86 *>          = 0: successful exit
  87 *>          < 0: if INFO = -k, the k-th argument had an illegal value
  88 *> \endverbatim
  89 *
  90 *  Authors:
  91 *  ========
  92 *
  93 *> \author Univ. of Tennessee
  94 *> \author Univ. of California Berkeley
  95 *> \author Univ. of Colorado Denver
  96 *> \author NAG Ltd.
  97 *
  98 *> \date September 2012
  99 *
 100 *> \ingroup complexOTHERauxiliary
 101 *
 102 *  =====================================================================
 103       SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO )
 104 *
 105 *  -- LAPACK auxiliary routine (version 3.4.2) --
 106 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 107 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 108 *     September 2012
 109 *
 110 *     .. Scalar Arguments ..
 111       CHARACTER          UPLO
 112       INTEGER            INFO, LDA, N
 113 *     ..
 114 *     .. Array Arguments ..
 115       COMPLEX            A( LDA, * )
 116 *     ..
 117 *
 118 *  =====================================================================
 119 *
 120 *     .. Parameters ..
 121       REAL               ONE
 122       PARAMETER          ( ONE = 1.0E+0 )
 123       COMPLEX            CONE
 124       PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
 125 *     ..
 126 *     .. Local Scalars ..
 127       LOGICAL            UPPER
 128       INTEGER            I, IB, NB
 129 *     ..
 130 *     .. External Functions ..
 131       LOGICAL            LSAME
 132       INTEGER            ILAENV
 133       EXTERNAL           LSAME, ILAENV
 134 *     ..
 135 *     .. External Subroutines ..
 136       EXTERNAL           CGEMM, CHERK, CLAUU2, CTRMM, XERBLA
 137 *     ..
 138 *     .. Intrinsic Functions ..
 139       INTRINSIC          MAX, MIN
 140 *     ..
 141 *     .. Executable Statements ..
 142 *
 143 *     Test the input parameters.
 144 *
 145       INFO = 0
 146       UPPER = LSAME( UPLO, 'U' )
 147       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
 148          INFO = -1
 149       ELSE IF( N.LT.0 ) THEN
 150          INFO = -2
 151       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
 152          INFO = -4
 153       END IF
 154       IF( INFO.NE.0 ) THEN
 155          CALL XERBLA( 'CLAUUM', -INFO )
 156          RETURN
 157       END IF
 158 *
 159 *     Quick return if possible
 160 *
 161       IF( N.EQ.0 )
 162      $   RETURN
 163 *
 164 *     Determine the block size for this environment.
 165 *
 166       NB = ILAENV( 1, 'CLAUUM', UPLO, N, -1, -1, -1 )
 167 *
 168       IF( NB.LE.1 .OR. NB.GE.N ) THEN
 169 *
 170 *        Use unblocked code
 171 *
 172          CALL CLAUU2( UPLO, N, A, LDA, INFO )
 173       ELSE
 174 *
 175 *        Use blocked code
 176 *
 177          IF( UPPER ) THEN
 178 *
 179 *           Compute the product U * U**H.
 180 *
 181             DO 10 I = 1, N, NB
 182                IB = MIN( NB, N-I+1 )
 183                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
 184      $                     'Non-unit', I-1, IB, CONE, A( I, I ), LDA,
 185      $                     A( 1, I ), LDA )
 186                CALL CLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
 187                IF( I+IB.LE.N ) THEN
 188                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
 189      $                        I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ),
 190      $                        LDA, A( I, I+IB ), LDA, CONE, A( 1, I ),
 191      $                        LDA )
 192                   CALL CHERK( 'Upper', 'No transpose', IB, N-I-IB+1,
 193      $                        ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
 194      $                        LDA )
 195                END IF
 196    10       CONTINUE
 197          ELSE
 198 *
 199 *           Compute the product L**H * L.
 200 *
 201             DO 20 I = 1, N, NB
 202                IB = MIN( NB, N-I+1 )
 203                CALL CTRMM( 'Left', 'Lower', 'Conjugate transpose',
 204      $                     'Non-unit', IB, I-1, CONE, A( I, I ), LDA,
 205      $                     A( I, 1 ), LDA )
 206                CALL CLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
 207                IF( I+IB.LE.N ) THEN
 208                   CALL CGEMM( 'Conjugate transpose', 'No transpose', IB,
 209      $                        I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA,
 210      $                        A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA )
 211                   CALL CHERK( 'Lower', 'Conjugate transpose', IB,
 212      $                        N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE,
 213      $                        A( I, I ), LDA )
 214                END IF
 215    20       CONTINUE
 216          END IF
 217       END IF
 218 *
 219       RETURN
 220 *
 221 *     End of CLAUUM
 222 *
 223       END