BLAS/SRC/zher.f

   1 *> \brief \b ZHER
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *  Definition:
   9 *  ===========
  10 *
  11 *       SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA)
  12 *
  13 *       .. Scalar Arguments ..
  14 *       DOUBLE PRECISION ALPHA
  15 *       INTEGER INCX,LDA,N
  16 *       CHARACTER UPLO
  17 *       ..
  18 *       .. Array Arguments ..
  19 *       COMPLEX*16 A(LDA,*),X(*)
  20 *       ..
  21 *
  22 *
  23 *> \par Purpose:
  24 *  =============
  25 *>
  26 *> \verbatim
  27 *>
  28 *> ZHER   performs the hermitian rank 1 operation
  29 *>
  30 *>    A := alpha*x*x**H + A,
  31 *>
  32 *> where alpha is a real scalar, x is an n element vector and A is an
  33 *> n by n hermitian matrix.
  34 *> \endverbatim
  35 *
  36 *  Arguments:
  37 *  ==========
  38 *
  39 *> \param[in] UPLO
  40 *> \verbatim
  41 *>          UPLO is CHARACTER*1
  42 *>           On entry, UPLO specifies whether the upper or lower
  43 *>           triangular part of the array A is to be referenced as
  44 *>           follows:
  45 *>
  46 *>              UPLO = 'U' or 'u'   Only the upper triangular part of A
  47 *>                                  is to be referenced.
  48 *>
  49 *>              UPLO = 'L' or 'l'   Only the lower triangular part of A
  50 *>                                  is to be referenced.
  51 *> \endverbatim
  52 *>
  53 *> \param[in] N
  54 *> \verbatim
  55 *>          N is INTEGER
  56 *>           On entry, N specifies the order of the matrix A.
  57 *>           N must be at least zero.
  58 *> \endverbatim
  59 *>
  60 *> \param[in] ALPHA
  61 *> \verbatim
  62 *>          ALPHA is DOUBLE PRECISION.
  63 *>           On entry, ALPHA specifies the scalar alpha.
  64 *> \endverbatim
  65 *>
  66 *> \param[in] X
  67 *> \verbatim
  68 *>          X is COMPLEX*16 array of dimension at least
  69 *>           ( 1 + ( n - 1 )*abs( INCX ) ).
  70 *>           Before entry, the incremented array X must contain the n
  71 *>           element vector x.
  72 *> \endverbatim
  73 *>
  74 *> \param[in] INCX
  75 *> \verbatim
  76 *>          INCX is INTEGER
  77 *>           On entry, INCX specifies the increment for the elements of
  78 *>           X. INCX must not be zero.
  79 *> \endverbatim
  80 *>
  81 *> \param[in,out] A
  82 *> \verbatim
  83 *>          A is COMPLEX*16 array of DIMENSION ( LDA, n ).
  84 *>           Before entry with  UPLO = 'U' or 'u', the leading n by n
  85 *>           upper triangular part of the array A must contain the upper
  86 *>           triangular part of the hermitian matrix and the strictly
  87 *>           lower triangular part of A is not referenced. On exit, the
  88 *>           upper triangular part of the array A is overwritten by the
  89 *>           upper triangular part of the updated matrix.
  90 *>           Before entry with UPLO = 'L' or 'l', the leading n by n
  91 *>           lower triangular part of the array A must contain the lower
  92 *>           triangular part of the hermitian matrix and the strictly
  93 *>           upper triangular part of A is not referenced. On exit, the
  94 *>           lower triangular part of the array A is overwritten by the
  95 *>           lower triangular part of the updated matrix.
  96 *>           Note that the imaginary parts of the diagonal elements need
  97 *>           not be set, they are assumed to be zero, and on exit they
  98 *>           are set to zero.
  99 *> \endverbatim
 100 *>
 101 *> \param[in] LDA
 102 *> \verbatim
 103 *>          LDA is INTEGER
 104 *>           On entry, LDA specifies the first dimension of A as declared
 105 *>           in the calling (sub) program. LDA must be at least
 106 *>           max( 1, n ).
 107 *> \endverbatim
 108 *
 109 *  Authors:
 110 *  ========
 111 *
 112 *> \author Univ. of Tennessee
 113 *> \author Univ. of California Berkeley
 114 *> \author Univ. of Colorado Denver
 115 *> \author NAG Ltd.
 116 *
 117 *> \date November 2011
 118 *
 119 *> \ingroup complex16_blas_level2
 120 *
 121 *> \par Further Details:
 122 *  =====================
 123 *>
 124 *> \verbatim
 125 *>
 126 *>  Level 2 Blas routine.
 127 *>
 128 *>  -- Written on 22-October-1986.
 129 *>     Jack Dongarra, Argonne National Lab.
 130 *>     Jeremy Du Croz, Nag Central Office.
 131 *>     Sven Hammarling, Nag Central Office.
 132 *>     Richard Hanson, Sandia National Labs.
 133 *> \endverbatim
 134 *>
 135 *  =====================================================================
 136       SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA)
 137 *
 138 *  -- Reference BLAS level2 routine (version 3.4.0) --
 139 *  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
 140 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 141 *     November 2011
 142 *
 143 *     .. Scalar Arguments ..
 144       DOUBLE PRECISION ALPHA
 145       INTEGER INCX,LDA,N
 146       CHARACTER UPLO
 147 *     ..
 148 *     .. Array Arguments ..
 149       COMPLEX*16 A(LDA,*),X(*)
 150 *     ..
 151 *
 152 *  =====================================================================
 153 *
 154 *     .. Parameters ..
 155       COMPLEX*16 ZERO
 156       PARAMETER (ZERO= (0.0D+0,0.0D+0))
 157 *     ..
 158 *     .. Local Scalars ..
 159       COMPLEX*16 TEMP
 160       INTEGER I,INFO,IX,J,JX,KX
 161 *     ..
 162 *     .. External Functions ..
 163       LOGICAL LSAME
 164       EXTERNAL LSAME
 165 *     ..
 166 *     .. External Subroutines ..
 167       EXTERNAL XERBLA
 168 *     ..
 169 *     .. Intrinsic Functions ..
 170       INTRINSIC DBLE,DCONJG,MAX
 171 *     ..
 172 *
 173 *     Test the input parameters.
 174 *
 175       INFO = 0
 176       IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
 177           INFO = 1
 178       ELSE IF (N.LT.0) THEN
 179           INFO = 2
 180       ELSE IF (INCX.EQ.0) THEN
 181           INFO = 5
 182       ELSE IF (LDA.LT.MAX(1,N)) THEN
 183           INFO = 7
 184       END IF
 185       IF (INFO.NE.0) THEN
 186           CALL XERBLA('ZHER  ',INFO)
 187           RETURN
 188       END IF
 189 *
 190 *     Quick return if possible.
 191 *
 192       IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(ZERO))) RETURN
 193 *
 194 *     Set the start point in X if the increment is not unity.
 195 *
 196       IF (INCX.LE.0) THEN
 197           KX = 1 - (N-1)*INCX
 198       ELSE IF (INCX.NE.1) THEN
 199           KX = 1
 200       END IF
 201 *
 202 *     Start the operations. In this version the elements of A are
 203 *     accessed sequentially with one pass through the triangular part
 204 *     of A.
 205 *
 206       IF (LSAME(UPLO,'U')) THEN
 207 *
 208 *        Form  A  when A is stored in upper triangle.
 209 *
 210           IF (INCX.EQ.1) THEN
 211               DO 20 J = 1,N
 212                   IF (X(J).NE.ZERO) THEN
 213                       TEMP = ALPHA*DCONJG(X(J))
 214                       DO 10 I = 1,J - 1
 215                           A(I,J) = A(I,J) + X(I)*TEMP
 216    10                 CONTINUE
 217                       A(J,J) = DBLE(A(J,J)) + DBLE(X(J)*TEMP)
 218                   ELSE
 219                       A(J,J) = DBLE(A(J,J))
 220                   END IF
 221    20         CONTINUE
 222           ELSE
 223               JX = KX
 224               DO 40 J = 1,N
 225                   IF (X(JX).NE.ZERO) THEN
 226                       TEMP = ALPHA*DCONJG(X(JX))
 227                       IX = KX
 228                       DO 30 I = 1,J - 1
 229                           A(I,J) = A(I,J) + X(IX)*TEMP
 230                           IX = IX + INCX
 231    30                 CONTINUE
 232                       A(J,J) = DBLE(A(J,J)) + DBLE(X(JX)*TEMP)
 233                   ELSE
 234                       A(J,J) = DBLE(A(J,J))
 235                   END IF
 236                   JX = JX + INCX
 237    40         CONTINUE
 238           END IF
 239       ELSE
 240 *
 241 *        Form  A  when A is stored in lower triangle.
 242 *
 243           IF (INCX.EQ.1) THEN
 244               DO 60 J = 1,N
 245                   IF (X(J).NE.ZERO) THEN
 246                       TEMP = ALPHA*DCONJG(X(J))
 247                       A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(J))
 248                       DO 50 I = J + 1,N
 249                           A(I,J) = A(I,J) + X(I)*TEMP
 250    50                 CONTINUE
 251                   ELSE
 252                       A(J,J) = DBLE(A(J,J))
 253                   END IF
 254    60         CONTINUE
 255           ELSE
 256               JX = KX
 257               DO 80 J = 1,N
 258                   IF (X(JX).NE.ZERO) THEN
 259                       TEMP = ALPHA*DCONJG(X(JX))
 260                       A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(JX))
 261                       IX = JX
 262                       DO 70 I = J + 1,N
 263                           IX = IX + INCX
 264                           A(I,J) = A(I,J) + X(IX)*TEMP
 265    70                 CONTINUE
 266                   ELSE
 267                       A(J,J) = DBLE(A(J,J))
 268                   END IF
 269                   JX = JX + INCX
 270    80         CONTINUE
 271           END IF
 272       END IF
 273 *
 274       RETURN
 275 *
 276 *     End of ZHER  .
 277 *
 278       END