SUBROUTINE STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,A,LDA, + B, LDB ) **************************************************************************** * * * DATA PARALLEL BLAS based on MPL * * * * Version 1.0 1/9-92 , * * For MasPar MP-1 computers * * * * para//ab, University of Bergen, NORWAY * * * * These programs must be called using F90 style array syntax. * * Note that the F77 style calling sequence has been retained * * in this version for compatibility reasons, be aware that * * parameters related to the array dimensions and shape therefore may * * be redundant and without any influence. * * The calling sequence may be changed in a future version. * * Please report any BUGs, ideas for improvement or other * * comments to * * adm@parallab.uib.no * * * * Future versions may then reflect your suggestions. * * The most current version of this software is available * * from netlib@nac.no , send the message `send index from maspar' * * * * REVISIONS: * * * **************************************************************************** implicit none * .. Scalar Arguments .. CHARACTER(1) SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB REAL ALPHA * .. Array Arguments .. REAL,ARRAY(:,:) :: A,B * .. * * Purpose * ======= * * STRSM solves one of the matrix equations * * op( A )*X = alpha*B, or X*op( A ) = alpha*B, * * where alpha is a scalar, X and B are m by n matrices, 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'. * * The matrix X is overwritten on B. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*B. * * SIDE = 'R' or 'r' X*op( A ) = alpha*B. * * 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 right-hand side matrix B, and on exit is * overwritten by the solution matrix X. * * 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. * * * 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. * * -- Restructured, blocked and tuned for IBM 3090 VF in August-1989. * Per Ling, * Institute of Information Processing, University of Umea, Sweden. * V1.R0. * * -- Modified for to run on Maspar MP-1 December 90 * by Hans Hatlestad, Institute of Informatics, * University of Bergen, Norway. * * * cts CMPF MPL MPL_STRSM_LOT, MPL_STRSM_UPT cmpf ondpu a, b CMPF MPL MPL_STRSM_LON, MPL_STRSM_UPN * .. Local Scalars .. INTEGER I, J, INFO, NROWA integer int_diag REAL,array(1:n,1:m) :: tmpB REAL,array(1:n,1:n) :: tmpA LOGICAL LSIDE, UPPER, NOTR, NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0D+0 ) cmpf ondpu tmpA, tmpB * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF 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.NOTR ).AND. + ( .NOT.LSAME( TRANSA, 'T' ) ).AND. + ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND. + ( .NOT.LSAME( DIAG , 'U' ) ) )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( 'STRSM ', 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 B=ZERO RETURN END IF **************************************************************************** * * Start the operations. * if (NOUNIT) then int_diag = 0 else int_diag = 1 endif IF( LSIDE )THEN * * Solve op( A )*X = alpha*B. * IF( UPPER )THEN IF( NOTR )THEN * Left, Upper, No transpose, MPL routine B = ALPHA * B CALL MPL_STRSM_UPN(int_diag, M, N, A, + LDA, B) ELSE * Left, Upper, Transpose, MPL routine A = TRANSPOSE(A) B = ALPHA * B CALL MPL_STRSM_LON(int_diag, M, N, A, + LDA, B) A = TRANSPOSE(A) END IF ELSE IF( NOTR )THEN * Left, Lower, No transpose, MPL routine B = ALPHA * B CALL MPL_STRSM_LON(int_diag, M, N, A, + LDA, B) ELSE * Left, Lower, Transpose, MPL routine A = TRANSPOSE(A) B = ALPHA * B CALL MPL_STRSM_UPN(int_diag, M, N, A, + LDA, B) A = TRANSPOSE(A) END IF END IF * ELSE ! Side = right * * Solve X*op( A ) = alpha*B. * IF( UPPER )THEN IF( NOTR )THEN * Right, Upper, No transpose, MPL routine tmpB = TRANSPOSE(B) tmpB = ALPHA * tmpB tmpA = TRANSPOSE(A) call MPL_STRSM_LON(int_diag,N,M,tmpA, + LDA,tmpB) B = TRANSPOSE(tmpB) ELSE * Right, Upper, Transpose, MPL routine tmpB = TRANSPOSE(B) tmpB = ALPHA * tmpB tmpA = A * write(*,*) 'kaller med R U T U/N ' * write(*,*) 'A =',N,'*',N,' lda =',LDA,'B =',N,'*',M call MPL_STRSM_UPN(int_diag,N,M,tmpA,LDA,tmpB) B = TRANSPOSE(tmpB) END IF ELSE IF( NOTR )THEN * Right, Lower, No transpose, MPL routine tmpB = TRANSPOSE(B) tmpB = ALPHA * tmpB tmpA = TRANSPOSE(A) call MPL_STRSM_UPN(int_diag,N,M,tmpA,LDA,tmpB) B = TRANSPOSE(tmpB) ELSE * Right, Lower, Transpose, MPL routine tmpA = A tmpB = TRANSPOSE(B) tmpB = ALPHA * tmpB call MPL_STRSM_LON(int_diag,N,M,tmpA,LDA,tmpB) B = TRANSPOSE(tmpB) END IF END IF END IF * RETURN * * End of STRSM . * END