zher2k.f

          SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
    *     .. Scalar Arguments ..
          DOUBLE COMPLEX ALPHA
          DOUBLE PRECISION BETA
          INTEGER K,LDA,LDB,LDC,N
          CHARACTER TRANS,UPLO
    *     ..
    *     .. Array Arguments ..
          DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  ZHER2K  performs one of the hermitian rank 2k operations
    *
    *     C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C,
    *
    *  or
    *
    *     C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C,
    *
    *  where  alpha and beta  are scalars with  beta  real,  C is an  n by n
    *  hermitian matrix and  A and B  are  n by k matrices in the first case
    *  and  k by n  matrices in the second case.
    *
    *  Arguments
    *  ==========
    *
    *  UPLO   - CHARACTER*1.
    *           On  entry,   UPLO  specifies  whether  the  upper  or  lower
    *           triangular  part  of the  array  C  is to be  referenced  as
    *           follows:
    *
    *              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
    *                                  is to be referenced.
    *
    *              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
    *                                  is to be referenced.
    *
    *           Unchanged on exit.
    *
    *  TRANS  - CHARACTER*1.
    *           On entry,  TRANS  specifies the operation to be performed as
    *           follows:
    *
    *              TRANS = 'N' or 'n'    C := alpha*A*conjg( B' )          +
    *                                         conjg( alpha )*B*conjg( A' ) +
    *                                         beta*C.
    *
    *              TRANS = 'C' or 'c'    C := alpha*conjg( A' )*B          +
    *                                         conjg( alpha )*conjg( B' )*A +
    *                                         beta*C.
    *
    *           Unchanged on exit.
    *
    *  N      - INTEGER.
    *           On entry,  N specifies the order of the matrix C.  N must be
    *           at least zero.
    *           Unchanged on exit.
    *
    *  K      - INTEGER.
    *           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
    *           of  columns  of the  matrices  A and B,  and on  entry  with
    *           TRANS = 'C' or 'c',  K  specifies  the number of rows of the
    *           matrices  A and B.  K must be at least zero.
    *           Unchanged on exit.
    *
    *  ALPHA  - COMPLEX*16         .
    *           On entry, ALPHA specifies the scalar alpha.
    *           Unchanged on exit.
    *
    *  A      - COMPLEX*16       array of DIMENSION ( LDA, ka ), where ka is
    *           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
    *           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
    *           part of the array  A  must contain the matrix  A,  otherwise
    *           the leading  k by n  part of the array  A  must contain  the
    *           matrix A.
    *           Unchanged on exit.
    *
    *  LDA    - INTEGER.
    *           On entry, LDA specifies the first dimension of A as declared
    *           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
    *           then  LDA must be at least  max( 1, n ), otherwise  LDA must
    *           be at least  max( 1, k ).
    *           Unchanged on exit.
    *
    *  B      - COMPLEX*16       array of DIMENSION ( LDB, kb ), where kb is
    *           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
    *           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
    *           part of the array  B  must contain the matrix  B,  otherwise
    *           the leading  k by n  part of the array  B  must contain  the
    *           matrix B.
    *           Unchanged on exit.
    *
    *  LDB    - INTEGER.
    *           On entry, LDB specifies the first dimension of B as declared
    *           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
    *           then  LDB must be at least  max( 1, n ), otherwise  LDB must
    *           be at least  max( 1, k ).
    *           Unchanged on exit.
    *
    *  BETA   - DOUBLE PRECISION            .
    *           On entry, BETA specifies the scalar beta.
    *           Unchanged on exit.
    *
    *  C      - COMPLEX*16          array of DIMENSION ( LDC, n ).
    *           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
    *           upper triangular part of the array C must contain the upper
    *           triangular part  of the  hermitian matrix  and the strictly
    *           lower triangular part of C is not referenced.  On exit, the
    *           upper triangular part of the array  C is overwritten by the
    *           upper triangular part of the updated matrix.
    *           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
    *           lower triangular part of the array C must contain the lower
    *           triangular part  of the  hermitian matrix  and the strictly
    *           upper triangular part of C is not referenced.  On exit, the
    *           lower triangular part of the array  C is overwritten by the
    *           lower triangular part of the updated matrix.
    *           Note that the imaginary parts of the diagonal elements need
    *           not be set,  they are assumed to be zero,  and on exit they
    *           are set to zero.
    *
    *  LDC    - INTEGER.
    *           On entry, LDC specifies the first dimension of C as declared
    *           in  the  calling  (sub)  program.   LDC  must  be  at  least
    *           max( 1, n ).
    *           Unchanged on exit.
    *
    *
    *  Level 3 Blas routine.
    *
    *  -- Written on 8-February-1989.
    *     Jack Dongarra, Argonne National Laboratory.
    *     Iain Duff, AERE Harwell.
    *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
    *     Sven Hammarling, Numerical Algorithms Group Ltd.
    *
    *  -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
    *     Ed Anderson, Cray Research Inc.
    *
    *
    *     .. External Functions ..
          LOGICAL LSAME
          EXTERNAL LSAME
    *     ..
    *     .. External Subroutines ..
          EXTERNAL XERBLA
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC DBLE,DCONJG,MAX
    *     ..
    *     .. Local Scalars ..
          DOUBLE COMPLEX TEMP1,TEMP2
          INTEGER I,INFO,J,L,NROWA
          LOGICAL UPPER
    *     ..
    *     .. Parameters ..
          DOUBLE PRECISION ONE
          PARAMETER (ONE=1.0D+0)
          DOUBLE COMPLEX ZERO
          PARAMETER (ZERO= (0.0D+0,0.0D+0))
    *     ..
    *
    *     Test the input parameters.
    *
          IF (LSAME(TRANS,'N')) THEN
              NROWA = N
          ELSE
              NROWA = K
          END IF
          UPPER = LSAME(UPLO,'U')
    *
          INFO = 0
          IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
              INFO = 1
          ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
         +         (.NOT.LSAME(TRANS,'C'))) THEN
              INFO = 2
          ELSE IF (N.LT.0) THEN
              INFO = 3
          ELSE IF (K.LT.0) THEN
              INFO = 4
          ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
              INFO = 7
          ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
              INFO = 9
          ELSE IF (LDC.LT.MAX(1,N)) THEN
              INFO = 12
          END IF
          IF (INFO.NE.0) THEN
              CALL XERBLA('ZHER2K',INFO)
              RETURN
          END IF
    *
    *     Quick return if possible.
    *
          IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
         +    (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
    *
    *     And when  alpha.eq.zero.
    *
          IF (ALPHA.EQ.ZERO) THEN
              IF (UPPER) THEN
                  IF (BETA.EQ.DBLE(ZERO)) THEN
                      DO 20 J = 1,N
                          DO 10 I = 1,J
                              C(I,J) = ZERO
       10                 CONTINUE
       20             CONTINUE
                  ELSE
                      DO 40 J = 1,N
                          DO 30 I = 1,J - 1
                              C(I,J) = BETA*C(I,J)
       30                 CONTINUE
                          C(J,J) = BETA*DBLE(C(J,J))
       40             CONTINUE
                  END IF
              ELSE
                  IF (BETA.EQ.DBLE(ZERO)) THEN
                      DO 60 J = 1,N
                          DO 50 I = J,N
                              C(I,J) = ZERO
       50                 CONTINUE
       60             CONTINUE
                  ELSE
                      DO 80 J = 1,N
                          C(J,J) = BETA*DBLE(C(J,J))
                          DO 70 I = J + 1,N
                              C(I,J) = BETA*C(I,J)
       70                 CONTINUE
       80             CONTINUE
                  END IF
              END IF
              RETURN
          END IF
    *
    *     Start the operations.
    *
          IF (LSAME(TRANS,'N')) THEN
    *
    *        Form  C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) +
    *                   C.
    *
              IF (UPPER) THEN
                  DO 130 J = 1,N
                      IF (BETA.EQ.DBLE(ZERO)) THEN
                          DO 90 I = 1,J
                              C(I,J) = ZERO
       90                 CONTINUE
                      ELSE IF (BETA.NE.ONE) THEN
                          DO 100 I = 1,J - 1
                              C(I,J) = BETA*C(I,J)
      100                 CONTINUE
                          C(J,J) = BETA*DBLE(C(J,J))
                      ELSE
                          C(J,J) = DBLE(C(J,J))
                      END IF
                      DO 120 L = 1,K
                          IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
                              TEMP1 = ALPHA*DCONJG(B(J,L))
                              TEMP2 = DCONJG(ALPHA*A(J,L))
                              DO 110 I = 1,J - 1
                                  C(I,J) = C(I,J) + A(I,L)*TEMP1 +
         +                                 B(I,L)*TEMP2
      110                     CONTINUE
                              C(J,J) = DBLE(C(J,J)) +
         +                             DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2)
                          END IF
      120             CONTINUE
      130         CONTINUE
              ELSE
                  DO 180 J = 1,N
                      IF (BETA.EQ.DBLE(ZERO)) THEN
                          DO 140 I = J,N
                              C(I,J) = ZERO
      140                 CONTINUE
                      ELSE IF (BETA.NE.ONE) THEN
                          DO 150 I = J + 1,N
                              C(I,J) = BETA*C(I,J)
      150                 CONTINUE
                          C(J,J) = BETA*DBLE(C(J,J))
                      ELSE
                          C(J,J) = DBLE(C(J,J))
                      END IF
                      DO 170 L = 1,K
                          IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
                              TEMP1 = ALPHA*DCONJG(B(J,L))
                              TEMP2 = DCONJG(ALPHA*A(J,L))
                              DO 160 I = J + 1,N
                                  C(I,J) = C(I,J) + A(I,L)*TEMP1 +
         +                                 B(I,L)*TEMP2
      160                     CONTINUE
                              C(J,J) = DBLE(C(J,J)) +
         +                             DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2)
                          END IF
      170             CONTINUE
      180         CONTINUE
              END IF
          ELSE
    *
    *        Form  C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A +
    *                   C.
    *
              IF (UPPER) THEN
                  DO 210 J = 1,N
                      DO 200 I = 1,J
                          TEMP1 = ZERO
                          TEMP2 = ZERO
                          DO 190 L = 1,K
                              TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J)
                              TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J)
      190                 CONTINUE
                          IF (I.EQ.J) THEN
                              IF (BETA.EQ.DBLE(ZERO)) THEN
                                  C(J,J) = DBLE(ALPHA*TEMP1+
         +                                 DCONJG(ALPHA)*TEMP2)
                              ELSE
                                  C(J,J) = BETA*DBLE(C(J,J)) +
         +                                 DBLE(ALPHA*TEMP1+
         +                                 DCONJG(ALPHA)*TEMP2)
                              END IF
                          ELSE
                              IF (BETA.EQ.DBLE(ZERO)) THEN
                                  C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2
                              ELSE
                                  C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
         +                                 DCONJG(ALPHA)*TEMP2
                              END IF
                          END IF
      200             CONTINUE
      210         CONTINUE
              ELSE
                  DO 240 J = 1,N
                      DO 230 I = J,N
                          TEMP1 = ZERO
                          TEMP2 = ZERO
                          DO 220 L = 1,K
                              TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J)
                              TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J)
      220                 CONTINUE
                          IF (I.EQ.J) THEN
                              IF (BETA.EQ.DBLE(ZERO)) THEN
                                  C(J,J) = DBLE(ALPHA*TEMP1+
         +                                 DCONJG(ALPHA)*TEMP2)
                              ELSE
                                  C(J,J) = BETA*DBLE(C(J,J)) +
         +                                 DBLE(ALPHA*TEMP1+
         +                                 DCONJG(ALPHA)*TEMP2)
                              END IF
                          ELSE
                              IF (BETA.EQ.DBLE(ZERO)) THEN
                                  C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2
                              ELSE
                                  C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
         +                                 DCONJG(ALPHA)*TEMP2
                              END IF
                          END IF
      230             CONTINUE
      240         CONTINUE
              END IF
          END IF
    *
          RETURN
    *
    *     End of ZHER2K.
    *
          END