LAPACK: BLAS/SRC/ctrmm.f Source File

Go to the documentation of this file.
00001       SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
00002 *     .. Scalar Arguments ..
00003       COMPLEX ALPHA
00004       INTEGER LDA,LDB,M,N
00005       CHARACTER DIAG,SIDE,TRANSA,UPLO
00006 *     ..
00007 *     .. Array Arguments ..
00008       COMPLEX A(LDA,*),B(LDB,*)
00009 *     ..
00010 *
00011 *  Purpose
00012 *  =======
00013 *
00014 *  CTRMM  performs one of the matrix-matrix operations
00015 *
00016 *     B := alpha*op( A )*B,   or   B := alpha*B*op( A )
00017 *
00018 *  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
00019 *  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
00020 *
00021 *     op( A ) = A   or   op( A ) = A'   or   op( A ) = conjg( A' ).
00022 *
00023 *  Arguments
00024 *  ==========
00025 *
00026 *  SIDE   - CHARACTER*1.
00027 *           On entry,  SIDE specifies whether  op( A ) multiplies B from
00028 *           the left or right as follows:
00029 *
00030 *              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
00031 *
00032 *              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
00033 *
00034 *           Unchanged on exit.
00035 *
00036 *  UPLO   - CHARACTER*1.
00037 *           On entry, UPLO specifies whether the matrix A is an upper or
00038 *           lower triangular matrix as follows:
00039 *
00040 *              UPLO = 'U' or 'u'   A is an upper triangular matrix.
00041 *
00042 *              UPLO = 'L' or 'l'   A is a lower triangular matrix.
00043 *
00044 *           Unchanged on exit.
00045 *
00046 *  TRANSA - CHARACTER*1.
00047 *           On entry, TRANSA specifies the form of op( A ) to be used in
00048 *           the matrix multiplication as follows:
00049 *
00050 *              TRANSA = 'N' or 'n'   op( A ) = A.
00051 *
00052 *              TRANSA = 'T' or 't'   op( A ) = A'.
00053 *
00054 *              TRANSA = 'C' or 'c'   op( A ) = conjg( A' ).
00055 *
00056 *           Unchanged on exit.
00057 *
00058 *  DIAG   - CHARACTER*1.
00059 *           On entry, DIAG specifies whether or not A is unit triangular
00060 *           as follows:
00061 *
00062 *              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
00063 *
00064 *              DIAG = 'N' or 'n'   A is not assumed to be unit
00065 *                                  triangular.
00066 *
00067 *           Unchanged on exit.
00068 *
00069 *  M      - INTEGER.
00070 *           On entry, M specifies the number of rows of B. M must be at
00071 *           least zero.
00072 *           Unchanged on exit.
00073 *
00074 *  N      - INTEGER.
00075 *           On entry, N specifies the number of columns of B.  N must be
00076 *           at least zero.
00077 *           Unchanged on exit.
00078 *
00079 *  ALPHA  - COMPLEX         .
00080 *           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
00081 *           zero then  A is not referenced and  B need not be set before
00082 *           entry.
00083 *           Unchanged on exit.
00084 *
00085 *  A      - COMPLEX          array of DIMENSION ( LDA, k ), where k is m
00086 *           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
00087 *           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
00088 *           upper triangular part of the array  A must contain the upper
00089 *           triangular matrix  and the strictly lower triangular part of
00090 *           A is not referenced.
00091 *           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
00092 *           lower triangular part of the array  A must contain the lower
00093 *           triangular matrix  and the strictly upper triangular part of
00094 *           A is not referenced.
00095 *           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
00096 *           A  are not referenced either,  but are assumed to be  unity.
00097 *           Unchanged on exit.
00098 *
00099 *  LDA    - INTEGER.
00100 *           On entry, LDA specifies the first dimension of A as declared
00101 *           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
00102 *           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
00103 *           then LDA must be at least max( 1, n ).
00104 *           Unchanged on exit.
00105 *
00106 *  B      - COMPLEX          array of DIMENSION ( LDB, n ).
00107 *           Before entry,  the leading  m by n part of the array  B must
00108 *           contain the matrix  B,  and  on exit  is overwritten  by the
00109 *           transformed matrix.
00110 *
00111 *  LDB    - INTEGER.
00112 *           On entry, LDB specifies the first dimension of B as declared
00113 *           in  the  calling  (sub)  program.   LDB  must  be  at  least
00114 *           max( 1, m ).
00115 *           Unchanged on exit.
00116 *
00117 *  Further Details
00118 *  ===============
00119 *
00120 *  Level 3 Blas routine.
00121 *
00122 *  -- Written on 8-February-1989.
00123 *     Jack Dongarra, Argonne National Laboratory.
00124 *     Iain Duff, AERE Harwell.
00125 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
00126 *     Sven Hammarling, Numerical Algorithms Group Ltd.
00127 *
00128 *  =====================================================================
00129 *
00130 *     .. External Functions ..
00131       LOGICAL LSAME
00132       EXTERNAL LSAME
00133 *     ..
00134 *     .. External Subroutines ..
00135       EXTERNAL XERBLA
00136 *     ..
00137 *     .. Intrinsic Functions ..
00138       INTRINSIC CONJG,MAX
00139 *     ..
00140 *     .. Local Scalars ..
00141       COMPLEX TEMP
00142       INTEGER I,INFO,J,K,NROWA
00143       LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
00144 *     ..
00145 *     .. Parameters ..
00146       COMPLEX ONE
00147       PARAMETER (ONE= (1.0E+0,0.0E+0))
00148       COMPLEX ZERO
00149       PARAMETER (ZERO= (0.0E+0,0.0E+0))
00150 *     ..
00151 *
00152 *     Test the input parameters.
00153 *
00154       LSIDE = LSAME(SIDE,'L')
00155       IF (LSIDE) THEN
00156           NROWA = M
00157       ELSE
00158           NROWA = N
00159       END IF
00160       NOCONJ = LSAME(TRANSA,'T')
00161       NOUNIT = LSAME(DIAG,'N')
00162       UPPER = LSAME(UPLO,'U')
00163 *
00164       INFO = 0
00165       IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
00166           INFO = 1
00167       ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
00168           INFO = 2
00169       ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
00170      +         (.NOT.LSAME(TRANSA,'T')) .AND.
00171      +         (.NOT.LSAME(TRANSA,'C'))) THEN
00172           INFO = 3
00173       ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
00174           INFO = 4
00175       ELSE IF (M.LT.0) THEN
00176           INFO = 5
00177       ELSE IF (N.LT.0) THEN
00178           INFO = 6
00179       ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
00180           INFO = 9
00181       ELSE IF (LDB.LT.MAX(1,M)) THEN
00182           INFO = 11
00183       END IF
00184       IF (INFO.NE.0) THEN
00185           CALL XERBLA('CTRMM ',INFO)
00186           RETURN
00187       END IF
00188 *
00189 *     Quick return if possible.
00190 *
00191       IF (M.EQ.0 .OR. N.EQ.0) RETURN
00192 *
00193 *     And when  alpha.eq.zero.
00194 *
00195       IF (ALPHA.EQ.ZERO) THEN
00196           DO 20 J = 1,N
00197               DO 10 I = 1,M
00198                   B(I,J) = ZERO
00199    10         CONTINUE
00200    20     CONTINUE
00201           RETURN
00202       END IF
00203 *
00204 *     Start the operations.
00205 *
00206       IF (LSIDE) THEN
00207           IF (LSAME(TRANSA,'N')) THEN
00208 *
00209 *           Form  B := alpha*A*B.
00210 *
00211               IF (UPPER) THEN
00212                   DO 50 J = 1,N
00213                       DO 40 K = 1,M
00214                           IF (B(K,J).NE.ZERO) THEN
00215                               TEMP = ALPHA*B(K,J)
00216                               DO 30 I = 1,K - 1
00217                                   B(I,J) = B(I,J) + TEMP*A(I,K)
00218    30                         CONTINUE
00219                               IF (NOUNIT) TEMP = TEMP*A(K,K)
00220                               B(K,J) = TEMP
00221                           END IF
00222    40                 CONTINUE
00223    50             CONTINUE
00224               ELSE
00225                   DO 80 J = 1,N
00226                       DO 70 K = M,1,-1
00227                           IF (B(K,J).NE.ZERO) THEN
00228                               TEMP = ALPHA*B(K,J)
00229                               B(K,J) = TEMP
00230                               IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
00231                               DO 60 I = K + 1,M
00232                                   B(I,J) = B(I,J) + TEMP*A(I,K)
00233    60                         CONTINUE
00234                           END IF
00235    70                 CONTINUE
00236    80             CONTINUE
00237               END IF
00238           ELSE
00239 *
00240 *           Form  B := alpha*A'*B   or   B := alpha*conjg( A' )*B.
00241 *
00242               IF (UPPER) THEN
00243                   DO 120 J = 1,N
00244                       DO 110 I = M,1,-1
00245                           TEMP = B(I,J)
00246                           IF (NOCONJ) THEN
00247                               IF (NOUNIT) TEMP = TEMP*A(I,I)
00248                               DO 90 K = 1,I - 1
00249                                   TEMP = TEMP + A(K,I)*B(K,J)
00250    90                         CONTINUE
00251                           ELSE
00252                               IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I))
00253                               DO 100 K = 1,I - 1
00254                                   TEMP = TEMP + CONJG(A(K,I))*B(K,J)
00255   100                         CONTINUE
00256                           END IF
00257                           B(I,J) = ALPHA*TEMP
00258   110                 CONTINUE
00259   120             CONTINUE
00260               ELSE
00261                   DO 160 J = 1,N
00262                       DO 150 I = 1,M
00263                           TEMP = B(I,J)
00264                           IF (NOCONJ) THEN
00265                               IF (NOUNIT) TEMP = TEMP*A(I,I)
00266                               DO 130 K = I + 1,M
00267                                   TEMP = TEMP + A(K,I)*B(K,J)
00268   130                         CONTINUE
00269                           ELSE
00270                               IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I))
00271                               DO 140 K = I + 1,M
00272                                   TEMP = TEMP + CONJG(A(K,I))*B(K,J)
00273   140                         CONTINUE
00274                           END IF
00275                           B(I,J) = ALPHA*TEMP
00276   150                 CONTINUE
00277   160             CONTINUE
00278               END IF
00279           END IF
00280       ELSE
00281           IF (LSAME(TRANSA,'N')) THEN
00282 *
00283 *           Form  B := alpha*B*A.
00284 *
00285               IF (UPPER) THEN
00286                   DO 200 J = N,1,-1
00287                       TEMP = ALPHA
00288                       IF (NOUNIT) TEMP = TEMP*A(J,J)
00289                       DO 170 I = 1,M
00290                           B(I,J) = TEMP*B(I,J)
00291   170                 CONTINUE
00292                       DO 190 K = 1,J - 1
00293                           IF (A(K,J).NE.ZERO) THEN
00294                               TEMP = ALPHA*A(K,J)
00295                               DO 180 I = 1,M
00296                                   B(I,J) = B(I,J) + TEMP*B(I,K)
00297   180                         CONTINUE
00298                           END IF
00299   190                 CONTINUE
00300   200             CONTINUE
00301               ELSE
00302                   DO 240 J = 1,N
00303                       TEMP = ALPHA
00304                       IF (NOUNIT) TEMP = TEMP*A(J,J)
00305                       DO 210 I = 1,M
00306                           B(I,J) = TEMP*B(I,J)
00307   210                 CONTINUE
00308                       DO 230 K = J + 1,N
00309                           IF (A(K,J).NE.ZERO) THEN
00310                               TEMP = ALPHA*A(K,J)
00311                               DO 220 I = 1,M
00312                                   B(I,J) = B(I,J) + TEMP*B(I,K)
00313   220                         CONTINUE
00314                           END IF
00315   230                 CONTINUE
00316   240             CONTINUE
00317               END IF
00318           ELSE
00319 *
00320 *           Form  B := alpha*B*A'   or   B := alpha*B*conjg( A' ).
00321 *
00322               IF (UPPER) THEN
00323                   DO 280 K = 1,N
00324                       DO 260 J = 1,K - 1
00325                           IF (A(J,K).NE.ZERO) THEN
00326                               IF (NOCONJ) THEN
00327                                   TEMP = ALPHA*A(J,K)
00328                               ELSE
00329                                   TEMP = ALPHA*CONJG(A(J,K))
00330                               END IF
00331                               DO 250 I = 1,M
00332                                   B(I,J) = B(I,J) + TEMP*B(I,K)
00333   250                         CONTINUE
00334                           END IF
00335   260                 CONTINUE
00336                       TEMP = ALPHA
00337                       IF (NOUNIT) THEN
00338                           IF (NOCONJ) THEN
00339                               TEMP = TEMP*A(K,K)
00340                           ELSE
00341                               TEMP = TEMP*CONJG(A(K,K))
00342                           END IF
00343                       END IF
00344                       IF (TEMP.NE.ONE) THEN
00345                           DO 270 I = 1,M
00346                               B(I,K) = TEMP*B(I,K)
00347   270                     CONTINUE
00348                       END IF
00349   280             CONTINUE
00350               ELSE
00351                   DO 320 K = N,1,-1
00352                       DO 300 J = K + 1,N
00353                           IF (A(J,K).NE.ZERO) THEN
00354                               IF (NOCONJ) THEN
00355                                   TEMP = ALPHA*A(J,K)
00356                               ELSE
00357                                   TEMP = ALPHA*CONJG(A(J,K))
00358                               END IF
00359                               DO 290 I = 1,M
00360                                   B(I,J) = B(I,J) + TEMP*B(I,K)
00361   290                         CONTINUE
00362                           END IF
00363   300                 CONTINUE
00364                       TEMP = ALPHA
00365                       IF (NOUNIT) THEN
00366                           IF (NOCONJ) THEN
00367                               TEMP = TEMP*A(K,K)
00368                           ELSE
00369                               TEMP = TEMP*CONJG(A(K,K))
00370                           END IF
00371                       END IF
00372                       IF (TEMP.NE.ONE) THEN
00373                           DO 310 I = 1,M
00374                               B(I,K) = TEMP*B(I,K)
00375   310                     CONTINUE
00376                       END IF
00377   320             CONTINUE
00378               END IF
00379           END IF
00380       END IF
00381 *
00382       RETURN
00383 *
00384 *     End of CTRMM .
00385 *
00386       END