BLAS/SRC/zsyrk.f

   1 *> \brief \b ZSYRK
   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 ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
  12 *
  13 *       .. Scalar Arguments ..
  14 *       COMPLEX*16 ALPHA,BETA
  15 *       INTEGER K,LDA,LDC,N
  16 *       CHARACTER TRANS,UPLO
  17 *       ..
  18 *       .. Array Arguments ..
  19 *       COMPLEX*16 A(LDA,*),C(LDC,*)
  20 *       ..
  21 *
  22 *
  23 *> \par Purpose:
  24 *  =============
  25 *>
  26 *> \verbatim
  27 *>
  28 *> ZSYRK  performs one of the symmetric rank k operations
  29 *>
  30 *>    C := alpha*A*A**T + beta*C,
  31 *>
  32 *> or
  33 *>
  34 *>    C := alpha*A**T*A + beta*C,
  35 *>
  36 *> where  alpha and beta  are scalars,  C is an  n by n symmetric matrix
  37 *> and  A  is an  n by k  matrix in the first case and a  k by n  matrix
  38 *> in the second case.
  39 *> \endverbatim
  40 *
  41 *  Arguments:
  42 *  ==========
  43 *
  44 *> \param[in] UPLO
  45 *> \verbatim
  46 *>          UPLO is CHARACTER*1
  47 *>           On  entry,   UPLO  specifies  whether  the  upper  or  lower
  48 *>           triangular  part  of the  array  C  is to be  referenced  as
  49 *>           follows:
  50 *>
  51 *>              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
  52 *>                                  is to be referenced.
  53 *>
  54 *>              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
  55 *>                                  is to be referenced.
  56 *> \endverbatim
  57 *>
  58 *> \param[in] TRANS
  59 *> \verbatim
  60 *>          TRANS is CHARACTER*1
  61 *>           On entry,  TRANS  specifies the operation to be performed as
  62 *>           follows:
  63 *>
  64 *>              TRANS = 'N' or 'n'   C := alpha*A*A**T + beta*C.
  65 *>
  66 *>              TRANS = 'T' or 't'   C := alpha*A**T*A + beta*C.
  67 *> \endverbatim
  68 *>
  69 *> \param[in] N
  70 *> \verbatim
  71 *>          N is INTEGER
  72 *>           On entry,  N specifies the order of the matrix C.  N must be
  73 *>           at least zero.
  74 *> \endverbatim
  75 *>
  76 *> \param[in] K
  77 *> \verbatim
  78 *>          K is INTEGER
  79 *>           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
  80 *>           of  columns   of  the   matrix   A,   and  on   entry   with
  81 *>           TRANS = 'T' or 't',  K  specifies  the number of rows of the
  82 *>           matrix A.  K must be at least zero.
  83 *> \endverbatim
  84 *>
  85 *> \param[in] ALPHA
  86 *> \verbatim
  87 *>          ALPHA is COMPLEX*16
  88 *>           On entry, ALPHA specifies the scalar alpha.
  89 *> \endverbatim
  90 *>
  91 *> \param[in] A
  92 *> \verbatim
  93 *>          A is COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
  94 *>           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
  95 *>           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
  96 *>           part of the array  A  must contain the matrix  A,  otherwise
  97 *>           the leading  k by n  part of the array  A  must contain  the
  98 *>           matrix A.
  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.   When  TRANS = 'N' or 'n'
 106 *>           then  LDA must be at least  max( 1, n ), otherwise  LDA must
 107 *>           be at least  max( 1, k ).
 108 *> \endverbatim
 109 *>
 110 *> \param[in] BETA
 111 *> \verbatim
 112 *>          BETA is COMPLEX*16
 113 *>           On entry, BETA specifies the scalar beta.
 114 *> \endverbatim
 115 *>
 116 *> \param[in,out] C
 117 *> \verbatim
 118 *>          C is COMPLEX*16 array of DIMENSION ( LDC, n ).
 119 *>           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
 120 *>           upper triangular part of the array C must contain the upper
 121 *>           triangular part  of the  symmetric matrix  and the strictly
 122 *>           lower triangular part of C is not referenced.  On exit, the
 123 *>           upper triangular part of the array  C is overwritten by the
 124 *>           upper triangular part of the updated matrix.
 125 *>           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
 126 *>           lower triangular part of the array C must contain the lower
 127 *>           triangular part  of the  symmetric matrix  and the strictly
 128 *>           upper triangular part of C is not referenced.  On exit, the
 129 *>           lower triangular part of the array  C is overwritten by the
 130 *>           lower triangular part of the updated matrix.
 131 *> \endverbatim
 132 *>
 133 *> \param[in] LDC
 134 *> \verbatim
 135 *>          LDC is INTEGER
 136 *>           On entry, LDC specifies the first dimension of C as declared
 137 *>           in  the  calling  (sub)  program.   LDC  must  be  at  least
 138 *>           max( 1, n ).
 139 *> \endverbatim
 140 *
 141 *  Authors:
 142 *  ========
 143 *
 144 *> \author Univ. of Tennessee
 145 *> \author Univ. of California Berkeley
 146 *> \author Univ. of Colorado Denver
 147 *> \author NAG Ltd.
 148 *
 149 *> \date November 2011
 150 *
 151 *> \ingroup complex16_blas_level3
 152 *
 153 *> \par Further Details:
 154 *  =====================
 155 *>
 156 *> \verbatim
 157 *>
 158 *>  Level 3 Blas routine.
 159 *>
 160 *>  -- Written on 8-February-1989.
 161 *>     Jack Dongarra, Argonne National Laboratory.
 162 *>     Iain Duff, AERE Harwell.
 163 *>     Jeremy Du Croz, Numerical Algorithms Group Ltd.
 164 *>     Sven Hammarling, Numerical Algorithms Group Ltd.
 165 *> \endverbatim
 166 *>
 167 *  =====================================================================
 168       SUBROUTINE ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
 169 *
 170 *  -- Reference BLAS level3 routine (version 3.4.0) --
 171 *  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
 172 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 173 *     November 2011
 174 *
 175 *     .. Scalar Arguments ..
 176       COMPLEX*16 ALPHA,BETA
 177       INTEGER K,LDA,LDC,N
 178       CHARACTER TRANS,UPLO
 179 *     ..
 180 *     .. Array Arguments ..
 181       COMPLEX*16 A(LDA,*),C(LDC,*)
 182 *     ..
 183 *
 184 *  =====================================================================
 185 *
 186 *     .. External Functions ..
 187       LOGICAL LSAME
 188       EXTERNAL LSAME
 189 *     ..
 190 *     .. External Subroutines ..
 191       EXTERNAL XERBLA
 192 *     ..
 193 *     .. Intrinsic Functions ..
 194       INTRINSIC MAX
 195 *     ..
 196 *     .. Local Scalars ..
 197       COMPLEX*16 TEMP
 198       INTEGER I,INFO,J,L,NROWA
 199       LOGICAL UPPER
 200 *     ..
 201 *     .. Parameters ..
 202       COMPLEX*16 ONE
 203       PARAMETER (ONE= (1.0D+0,0.0D+0))
 204       COMPLEX*16 ZERO
 205       PARAMETER (ZERO= (0.0D+0,0.0D+0))
 206 *     ..
 207 *
 208 *     Test the input parameters.
 209 *
 210       IF (LSAME(TRANS,'N')) THEN
 211           NROWA = N
 212       ELSE
 213           NROWA = K
 214       END IF
 215       UPPER = LSAME(UPLO,'U')
 216 *
 217       INFO = 0
 218       IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
 219           INFO = 1
 220       ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
 221      +         (.NOT.LSAME(TRANS,'T'))) THEN
 222           INFO = 2
 223       ELSE IF (N.LT.0) THEN
 224           INFO = 3
 225       ELSE IF (K.LT.0) THEN
 226           INFO = 4
 227       ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
 228           INFO = 7
 229       ELSE IF (LDC.LT.MAX(1,N)) THEN
 230           INFO = 10
 231       END IF
 232       IF (INFO.NE.0) THEN
 233           CALL XERBLA('ZSYRK ',INFO)
 234           RETURN
 235       END IF
 236 *
 237 *     Quick return if possible.
 238 *
 239       IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
 240      +    (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
 241 *
 242 *     And when  alpha.eq.zero.
 243 *
 244       IF (ALPHA.EQ.ZERO) THEN
 245           IF (UPPER) THEN
 246               IF (BETA.EQ.ZERO) THEN
 247                   DO 20 J = 1,N
 248                       DO 10 I = 1,J
 249                           C(I,J) = ZERO
 250    10                 CONTINUE
 251    20             CONTINUE
 252               ELSE
 253                   DO 40 J = 1,N
 254                       DO 30 I = 1,J
 255                           C(I,J) = BETA*C(I,J)
 256    30                 CONTINUE
 257    40             CONTINUE
 258               END IF
 259           ELSE
 260               IF (BETA.EQ.ZERO) THEN
 261                   DO 60 J = 1,N
 262                       DO 50 I = J,N
 263                           C(I,J) = ZERO
 264    50                 CONTINUE
 265    60             CONTINUE
 266               ELSE
 267                   DO 80 J = 1,N
 268                       DO 70 I = J,N
 269                           C(I,J) = BETA*C(I,J)
 270    70                 CONTINUE
 271    80             CONTINUE
 272               END IF
 273           END IF
 274           RETURN
 275       END IF
 276 *
 277 *     Start the operations.
 278 *
 279       IF (LSAME(TRANS,'N')) THEN
 280 *
 281 *        Form  C := alpha*A*A**T + beta*C.
 282 *
 283           IF (UPPER) THEN
 284               DO 130 J = 1,N
 285                   IF (BETA.EQ.ZERO) THEN
 286                       DO 90 I = 1,J
 287                           C(I,J) = ZERO
 288    90                 CONTINUE
 289                   ELSE IF (BETA.NE.ONE) THEN
 290                       DO 100 I = 1,J
 291                           C(I,J) = BETA*C(I,J)
 292   100                 CONTINUE
 293                   END IF
 294                   DO 120 L = 1,K
 295                       IF (A(J,L).NE.ZERO) THEN
 296                           TEMP = ALPHA*A(J,L)
 297                           DO 110 I = 1,J
 298                               C(I,J) = C(I,J) + TEMP*A(I,L)
 299   110                     CONTINUE
 300                       END IF
 301   120             CONTINUE
 302   130         CONTINUE
 303           ELSE
 304               DO 180 J = 1,N
 305                   IF (BETA.EQ.ZERO) THEN
 306                       DO 140 I = J,N
 307                           C(I,J) = ZERO
 308   140                 CONTINUE
 309                   ELSE IF (BETA.NE.ONE) THEN
 310                       DO 150 I = J,N
 311                           C(I,J) = BETA*C(I,J)
 312   150                 CONTINUE
 313                   END IF
 314                   DO 170 L = 1,K
 315                       IF (A(J,L).NE.ZERO) THEN
 316                           TEMP = ALPHA*A(J,L)
 317                           DO 160 I = J,N
 318                               C(I,J) = C(I,J) + TEMP*A(I,L)
 319   160                     CONTINUE
 320                       END IF
 321   170             CONTINUE
 322   180         CONTINUE
 323           END IF
 324       ELSE
 325 *
 326 *        Form  C := alpha*A**T*A + beta*C.
 327 *
 328           IF (UPPER) THEN
 329               DO 210 J = 1,N
 330                   DO 200 I = 1,J
 331                       TEMP = ZERO
 332                       DO 190 L = 1,K
 333                           TEMP = TEMP + A(L,I)*A(L,J)
 334   190                 CONTINUE
 335                       IF (BETA.EQ.ZERO) THEN
 336                           C(I,J) = ALPHA*TEMP
 337                       ELSE
 338                           C(I,J) = ALPHA*TEMP + BETA*C(I,J)
 339                       END IF
 340   200             CONTINUE
 341   210         CONTINUE
 342           ELSE
 343               DO 240 J = 1,N
 344                   DO 230 I = J,N
 345                       TEMP = ZERO
 346                       DO 220 L = 1,K
 347                           TEMP = TEMP + A(L,I)*A(L,J)
 348   220                 CONTINUE
 349                       IF (BETA.EQ.ZERO) THEN
 350                           C(I,J) = ALPHA*TEMP
 351                       ELSE
 352                           C(I,J) = ALPHA*TEMP + BETA*C(I,J)
 353                       END IF
 354   230             CONTINUE
 355   240         CONTINUE
 356           END IF
 357       END IF
 358 *
 359       RETURN
 360 *
 361 *     End of ZSYRK .
 362 *
 363       END