SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) * .. Scalar Arguments .. REAL ALPHA INTEGER LDA,LDB,M,N CHARACTER DIAG,SIDE,TRANSA,UPLO * .. * .. Array Arguments .. REAL A(LDA,*),B(LDB,*) * .. * * Purpose * ======= * * STRMM performs one of the matrix-matrix operations * * B := alpha*op( A )*B, or B := alpha*B*op( A ), * * where alpha is a scalar, B is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Arguments * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies B from * the left or right as follows: * * SIDE = 'L' or 'l' B := alpha*op( A )*B. * * SIDE = 'R' or 'r' B := alpha*B*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B, and on exit is overwritten by the * transformed matrix. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * Further Details * =============== * * 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. * * ===================================================================== * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Local Scalars .. REAL TEMP INTEGER I,INFO,J,K,NROWA LOGICAL LSIDE,NOUNIT,UPPER * .. * .. Parameters .. REAL ONE,ZERO PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) * .. * * Test the input parameters. * LSIDE = LSAME(SIDE,'L') IF (LSIDE) THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME(DIAG,'N') UPPER = LSAME(UPLO,'U') * INFO = 0 IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN INFO = 1 ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN INFO = 2 ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND. + (.NOT.LSAME(TRANSA,'T')) .AND. + (.NOT.LSAME(TRANSA,'C'))) THEN INFO = 3 ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN INFO = 4 ELSE IF (M.LT.0) THEN INFO = 5 ELSE IF (N.LT.0) THEN INFO = 6 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN INFO = 9 ELSE IF (LDB.LT.MAX(1,M)) THEN INFO = 11 END IF IF (INFO.NE.0) THEN CALL XERBLA('STRMM ',INFO) RETURN END IF * * Quick return if possible. * IF (M.EQ.0 .OR. N.EQ.0) RETURN * * And when alpha.eq.zero. * IF (ALPHA.EQ.ZERO) THEN DO 20 J = 1,N DO 10 I = 1,M B(I,J) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF (LSIDE) THEN IF (LSAME(TRANSA,'N')) THEN * * Form B := alpha*A*B. * IF (UPPER) THEN DO 50 J = 1,N DO 40 K = 1,M IF (B(K,J).NE.ZERO) THEN TEMP = ALPHA*B(K,J) DO 30 I = 1,K - 1 B(I,J) = B(I,J) + TEMP*A(I,K) 30 CONTINUE IF (NOUNIT) TEMP = TEMP*A(K,K) B(K,J) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80 J = 1,N DO 70 K = M,1,-1 IF (B(K,J).NE.ZERO) THEN TEMP = ALPHA*B(K,J) B(K,J) = TEMP IF (NOUNIT) B(K,J) = B(K,J)*A(K,K) DO 60 I = K + 1,M B(I,J) = B(I,J) + TEMP*A(I,K) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE * * Form B := alpha*A'*B. * IF (UPPER) THEN DO 110 J = 1,N DO 100 I = M,1,-1 TEMP = B(I,J) IF (NOUNIT) TEMP = TEMP*A(I,I) DO 90 K = 1,I - 1 TEMP = TEMP + A(K,I)*B(K,J) 90 CONTINUE B(I,J) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140 J = 1,N DO 130 I = 1,M TEMP = B(I,J) IF (NOUNIT) TEMP = TEMP*A(I,I) DO 120 K = I + 1,M TEMP = TEMP + A(K,I)*B(K,J) 120 CONTINUE B(I,J) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE END IF END IF ELSE IF (LSAME(TRANSA,'N')) THEN * * Form B := alpha*B*A. * IF (UPPER) THEN DO 180 J = N,1,-1 TEMP = ALPHA IF (NOUNIT) TEMP = TEMP*A(J,J) DO 150 I = 1,M B(I,J) = TEMP*B(I,J) 150 CONTINUE DO 170 K = 1,J - 1 IF (A(K,J).NE.ZERO) THEN TEMP = ALPHA*A(K,J) DO 160 I = 1,M B(I,J) = B(I,J) + TEMP*B(I,K) 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE ELSE DO 220 J = 1,N TEMP = ALPHA IF (NOUNIT) TEMP = TEMP*A(J,J) DO 190 I = 1,M B(I,J) = TEMP*B(I,J) 190 CONTINUE DO 210 K = J + 1,N IF (A(K,J).NE.ZERO) THEN TEMP = ALPHA*A(K,J) DO 200 I = 1,M B(I,J) = B(I,J) + TEMP*B(I,K) 200 CONTINUE END IF 210 CONTINUE 220 CONTINUE END IF ELSE * * Form B := alpha*B*A'. * IF (UPPER) THEN DO 260 K = 1,N DO 240 J = 1,K - 1 IF (A(J,K).NE.ZERO) THEN TEMP = ALPHA*A(J,K) DO 230 I = 1,M B(I,J) = B(I,J) + TEMP*B(I,K) 230 CONTINUE END IF 240 CONTINUE TEMP = ALPHA IF (NOUNIT) TEMP = TEMP*A(K,K) IF (TEMP.NE.ONE) THEN DO 250 I = 1,M B(I,K) = TEMP*B(I,K) 250 CONTINUE END IF 260 CONTINUE ELSE DO 300 K = N,1,-1 DO 280 J = K + 1,N IF (A(J,K).NE.ZERO) THEN TEMP = ALPHA*A(J,K) DO 270 I = 1,M B(I,J) = B(I,J) + TEMP*B(I,K) 270 CONTINUE END IF 280 CONTINUE TEMP = ALPHA IF (NOUNIT) TEMP = TEMP*A(K,K) IF (TEMP.NE.ONE) THEN DO 290 I = 1,M B(I,K) = TEMP*B(I,K) 290 CONTINUE END IF 300 CONTINUE END IF END IF END IF * RETURN * * End of STRMM . * END