Return to zher2k.f CVS log

Up to [local] / rpl / lapack / blas

Cohérence.

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