LAPACK 3.3.0

chemm.f

Go to the documentation of this file.
00001       SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
00002 *     .. Scalar Arguments ..
00003       COMPLEX ALPHA,BETA
00004       INTEGER LDA,LDB,LDC,M,N
00005       CHARACTER SIDE,UPLO
00006 *     ..
00007 *     .. Array Arguments ..
00008       COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
00009 *     ..
00010 *
00011 *  Purpose
00012 *  =======
00013 *
00014 *  CHEMM  performs one of the matrix-matrix operations
00015 *
00016 *     C := alpha*A*B + beta*C,
00017 *
00018 *  or
00019 *
00020 *     C := alpha*B*A + beta*C,
00021 *
00022 *  where alpha and beta are scalars, A is an hermitian matrix and  B and
00023 *  C are m by n matrices.
00024 *
00025 *  Arguments
00026 *  ==========
00027 *
00028 *  SIDE   - CHARACTER*1.
00029 *           On entry,  SIDE  specifies whether  the  hermitian matrix  A
00030 *           appears on the  left or right  in the  operation as follows:
00031 *
00032 *              SIDE = 'L' or 'l'   C := alpha*A*B + beta*C,
00033 *
00034 *              SIDE = 'R' or 'r'   C := alpha*B*A + beta*C,
00035 *
00036 *           Unchanged on exit.
00037 *
00038 *  UPLO   - CHARACTER*1.
00039 *           On  entry,   UPLO  specifies  whether  the  upper  or  lower
00040 *           triangular  part  of  the  hermitian  matrix   A  is  to  be
00041 *           referenced as follows:
00042 *
00043 *              UPLO = 'U' or 'u'   Only the upper triangular part of the
00044 *                                  hermitian matrix is to be referenced.
00045 *
00046 *              UPLO = 'L' or 'l'   Only the lower triangular part of the
00047 *                                  hermitian matrix is to be referenced.
00048 *
00049 *           Unchanged on exit.
00050 *
00051 *  M      - INTEGER.
00052 *           On entry,  M  specifies the number of rows of the matrix  C.
00053 *           M  must be at least zero.
00054 *           Unchanged on exit.
00055 *
00056 *  N      - INTEGER.
00057 *           On entry, N specifies the number of columns of the matrix C.
00058 *           N  must be at least zero.
00059 *           Unchanged on exit.
00060 *
00061 *  ALPHA  - COMPLEX         .
00062 *           On entry, ALPHA specifies the scalar alpha.
00063 *           Unchanged on exit.
00064 *
00065 *  A      - COMPLEX          array of DIMENSION ( LDA, ka ), where ka is
00066 *           m  when  SIDE = 'L' or 'l'  and is n  otherwise.
00067 *           Before entry  with  SIDE = 'L' or 'l',  the  m by m  part of
00068 *           the array  A  must contain the  hermitian matrix,  such that
00069 *           when  UPLO = 'U' or 'u', the leading m by m upper triangular
00070 *           part of the array  A  must contain the upper triangular part
00071 *           of the  hermitian matrix and the  strictly  lower triangular
00072 *           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
00073 *           the leading  m by m  lower triangular part  of the  array  A
00074 *           must  contain  the  lower triangular part  of the  hermitian
00075 *           matrix and the  strictly upper triangular part of  A  is not
00076 *           referenced.
00077 *           Before entry  with  SIDE = 'R' or 'r',  the  n by n  part of
00078 *           the array  A  must contain the  hermitian matrix,  such that
00079 *           when  UPLO = 'U' or 'u', the leading n by n upper triangular
00080 *           part of the array  A  must contain the upper triangular part
00081 *           of the  hermitian matrix and the  strictly  lower triangular
00082 *           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
00083 *           the leading  n by n  lower triangular part  of the  array  A
00084 *           must  contain  the  lower triangular part  of the  hermitian
00085 *           matrix and the  strictly upper triangular part of  A  is not
00086 *           referenced.
00087 *           Note that the imaginary parts  of the diagonal elements need
00088 *           not be set, they are assumed to be zero.
00089 *           Unchanged on exit.
00090 *
00091 *  LDA    - INTEGER.
00092 *           On entry, LDA specifies the first dimension of A as declared
00093 *           in the  calling (sub) program. When  SIDE = 'L' or 'l'  then
00094 *           LDA must be at least  max( 1, m ), otherwise  LDA must be at
00095 *           least max( 1, n ).
00096 *           Unchanged on exit.
00097 *
00098 *  B      - COMPLEX          array of DIMENSION ( LDB, n ).
00099 *           Before entry, the leading  m by n part of the array  B  must
00100 *           contain the matrix B.
00101 *           Unchanged on exit.
00102 *
00103 *  LDB    - INTEGER.
00104 *           On entry, LDB specifies the first dimension of B as declared
00105 *           in  the  calling  (sub)  program.   LDB  must  be  at  least
00106 *           max( 1, m ).
00107 *           Unchanged on exit.
00108 *
00109 *  BETA   - COMPLEX         .
00110 *           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
00111 *           supplied as zero then C need not be set on input.
00112 *           Unchanged on exit.
00113 *
00114 *  C      - COMPLEX          array of DIMENSION ( LDC, n ).
00115 *           Before entry, the leading  m by n  part of the array  C must
00116 *           contain the matrix  C,  except when  beta  is zero, in which
00117 *           case C need not be set on entry.
00118 *           On exit, the array  C  is overwritten by the  m by n updated
00119 *           matrix.
00120 *
00121 *  LDC    - INTEGER.
00122 *           On entry, LDC specifies the first dimension of C as declared
00123 *           in  the  calling  (sub)  program.   LDC  must  be  at  least
00124 *           max( 1, m ).
00125 *           Unchanged on exit.
00126 *
00127 *  Further Details
00128 *  ===============
00129 *
00130 *  Level 3 Blas routine.
00131 *
00132 *  -- Written on 8-February-1989.
00133 *     Jack Dongarra, Argonne National Laboratory.
00134 *     Iain Duff, AERE Harwell.
00135 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
00136 *     Sven Hammarling, Numerical Algorithms Group Ltd.
00137 *
00138 *  =====================================================================
00139 *
00140 *     .. External Functions ..
00141       LOGICAL LSAME
00142       EXTERNAL LSAME
00143 *     ..
00144 *     .. External Subroutines ..
00145       EXTERNAL XERBLA
00146 *     ..
00147 *     .. Intrinsic Functions ..
00148       INTRINSIC CONJG,MAX,REAL
00149 *     ..
00150 *     .. Local Scalars ..
00151       COMPLEX TEMP1,TEMP2
00152       INTEGER I,INFO,J,K,NROWA
00153       LOGICAL UPPER
00154 *     ..
00155 *     .. Parameters ..
00156       COMPLEX ONE
00157       PARAMETER (ONE= (1.0E+0,0.0E+0))
00158       COMPLEX ZERO
00159       PARAMETER (ZERO= (0.0E+0,0.0E+0))
00160 *     ..
00161 *
00162 *     Set NROWA as the number of rows of A.
00163 *
00164       IF (LSAME(SIDE,'L')) THEN
00165           NROWA = M
00166       ELSE
00167           NROWA = N
00168       END IF
00169       UPPER = LSAME(UPLO,'U')
00170 *
00171 *     Test the input parameters.
00172 *
00173       INFO = 0
00174       IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
00175           INFO = 1
00176       ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
00177           INFO = 2
00178       ELSE IF (M.LT.0) THEN
00179           INFO = 3
00180       ELSE IF (N.LT.0) THEN
00181           INFO = 4
00182       ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
00183           INFO = 7
00184       ELSE IF (LDB.LT.MAX(1,M)) THEN
00185           INFO = 9
00186       ELSE IF (LDC.LT.MAX(1,M)) THEN
00187           INFO = 12
00188       END IF
00189       IF (INFO.NE.0) THEN
00190           CALL XERBLA('CHEMM ',INFO)
00191           RETURN
00192       END IF
00193 *
00194 *     Quick return if possible.
00195 *
00196       IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
00197      +    ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
00198 *
00199 *     And when  alpha.eq.zero.
00200 *
00201       IF (ALPHA.EQ.ZERO) THEN
00202           IF (BETA.EQ.ZERO) THEN
00203               DO 20 J = 1,N
00204                   DO 10 I = 1,M
00205                       C(I,J) = ZERO
00206    10             CONTINUE
00207    20         CONTINUE
00208           ELSE
00209               DO 40 J = 1,N
00210                   DO 30 I = 1,M
00211                       C(I,J) = BETA*C(I,J)
00212    30             CONTINUE
00213    40         CONTINUE
00214           END IF
00215           RETURN
00216       END IF
00217 *
00218 *     Start the operations.
00219 *
00220       IF (LSAME(SIDE,'L')) THEN
00221 *
00222 *        Form  C := alpha*A*B + beta*C.
00223 *
00224           IF (UPPER) THEN
00225               DO 70 J = 1,N
00226                   DO 60 I = 1,M
00227                       TEMP1 = ALPHA*B(I,J)
00228                       TEMP2 = ZERO
00229                       DO 50 K = 1,I - 1
00230                           C(K,J) = C(K,J) + TEMP1*A(K,I)
00231                           TEMP2 = TEMP2 + B(K,J)*CONJG(A(K,I))
00232    50                 CONTINUE
00233                       IF (BETA.EQ.ZERO) THEN
00234                           C(I,J) = TEMP1*REAL(A(I,I)) + ALPHA*TEMP2
00235                       ELSE
00236                           C(I,J) = BETA*C(I,J) + TEMP1*REAL(A(I,I)) +
00237      +                             ALPHA*TEMP2
00238                       END IF
00239    60             CONTINUE
00240    70         CONTINUE
00241           ELSE
00242               DO 100 J = 1,N
00243                   DO 90 I = M,1,-1
00244                       TEMP1 = ALPHA*B(I,J)
00245                       TEMP2 = ZERO
00246                       DO 80 K = I + 1,M
00247                           C(K,J) = C(K,J) + TEMP1*A(K,I)
00248                           TEMP2 = TEMP2 + B(K,J)*CONJG(A(K,I))
00249    80                 CONTINUE
00250                       IF (BETA.EQ.ZERO) THEN
00251                           C(I,J) = TEMP1*REAL(A(I,I)) + ALPHA*TEMP2
00252                       ELSE
00253                           C(I,J) = BETA*C(I,J) + TEMP1*REAL(A(I,I)) +
00254      +                             ALPHA*TEMP2
00255                       END IF
00256    90             CONTINUE
00257   100         CONTINUE
00258           END IF
00259       ELSE
00260 *
00261 *        Form  C := alpha*B*A + beta*C.
00262 *
00263           DO 170 J = 1,N
00264               TEMP1 = ALPHA*REAL(A(J,J))
00265               IF (BETA.EQ.ZERO) THEN
00266                   DO 110 I = 1,M
00267                       C(I,J) = TEMP1*B(I,J)
00268   110             CONTINUE
00269               ELSE
00270                   DO 120 I = 1,M
00271                       C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
00272   120             CONTINUE
00273               END IF
00274               DO 140 K = 1,J - 1
00275                   IF (UPPER) THEN
00276                       TEMP1 = ALPHA*A(K,J)
00277                   ELSE
00278                       TEMP1 = ALPHA*CONJG(A(J,K))
00279                   END IF
00280                   DO 130 I = 1,M
00281                       C(I,J) = C(I,J) + TEMP1*B(I,K)
00282   130             CONTINUE
00283   140         CONTINUE
00284               DO 160 K = J + 1,N
00285                   IF (UPPER) THEN
00286                       TEMP1 = ALPHA*CONJG(A(J,K))
00287                   ELSE
00288                       TEMP1 = ALPHA*A(K,J)
00289                   END IF
00290                   DO 150 I = 1,M
00291                       C(I,J) = C(I,J) + TEMP1*B(I,K)
00292   150             CONTINUE
00293   160         CONTINUE
00294   170     CONTINUE
00295       END IF
00296 *
00297       RETURN
00298 *
00299 *     End of CHEMM .
00300 *
00301       END
 All Files Functions