SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER K,LDA,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),C(LDC,*)
* ..
*
* Purpose
* =======
*
* CHERK performs one of the hermitian rank k operations
*
* C := alpha*A*conjg( A' ) + beta*C,
*
* or
*
* C := alpha*conjg( A' )*A + beta*C,
*
* where alpha and beta are real scalars, C is an n by n hermitian
* matrix and A is an n by k matrix in the first case and a k by n
* matrix 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( A' ) + beta*C.
*
* TRANS = 'C' or 'c' C := alpha*conjg( A' )*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 matrix A, and on entry with
* TRANS = 'C' or 'c', K specifies the number of rows of the
* matrix A. K must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - COMPLEX 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.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* C - COMPLEX 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 REAL( C(J,J) ) when BETA = 1.
* Ed Anderson, Cray Research Inc.
*
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CMPLX,CONJG,MAX,REAL
* ..
* .. Local Scalars ..
COMPLEX TEMP
REAL RTEMP
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+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 (LDC.LT.MAX(1,N)) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHERK ',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.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*REAL(C(J,J))
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.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*REAL(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( A' ) + beta*C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.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*REAL(C(J,J))
ELSE
C(J,J) = REAL(C(J,J))
END IF
DO 120 L = 1,K
IF (A(J,L).NE.CMPLX(ZERO)) THEN
TEMP = ALPHA*CONJG(A(J,L))
DO 110 I = 1,J - 1
C(I,J) = C(I,J) + TEMP*A(I,L)
110 CONTINUE
C(J,J) = REAL(C(J,J)) + REAL(TEMP*A(I,L))
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
C(J,J) = BETA*REAL(C(J,J))
DO 150 I = J + 1,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
ELSE
C(J,J) = REAL(C(J,J))
END IF
DO 170 L = 1,K
IF (A(J,L).NE.CMPLX(ZERO)) THEN
TEMP = ALPHA*CONJG(A(J,L))
C(J,J) = REAL(C(J,J)) + REAL(TEMP*A(J,L))
DO 160 I = J + 1,N
C(I,J) = C(I,J) + TEMP*A(I,L)
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*conjg( A' )*A + beta*C.
*
IF (UPPER) THEN
DO 220 J = 1,N
DO 200 I = 1,J - 1
TEMP = ZERO
DO 190 L = 1,K
TEMP = TEMP + CONJG(A(L,I))*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
200 CONTINUE
RTEMP = ZERO
DO 210 L = 1,K
RTEMP = RTEMP + CONJG(A(L,J))*A(L,J)
210 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(J,J) = ALPHA*RTEMP
ELSE
C(J,J) = ALPHA*RTEMP + BETA*REAL(C(J,J))
END IF
220 CONTINUE
ELSE
DO 260 J = 1,N
RTEMP = ZERO
DO 230 L = 1,K
RTEMP = RTEMP + CONJG(A(L,J))*A(L,J)
230 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(J,J) = ALPHA*RTEMP
ELSE
C(J,J) = ALPHA*RTEMP + BETA*REAL(C(J,J))
END IF
DO 250 I = J + 1,N
TEMP = ZERO
DO 240 L = 1,K
TEMP = TEMP + CONJG(A(L,I))*A(L,J)
240 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
250 CONTINUE
260 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHERK .
*
END