summaryrefslogtreecommitdiff
path: root/src/lib/blas/ztrsm.f
diff options
context:
space:
mode:
Diffstat (limited to 'src/lib/blas/ztrsm.f')
-rw-r--r--src/lib/blas/ztrsm.f414
1 files changed, 0 insertions, 414 deletions
diff --git a/src/lib/blas/ztrsm.f b/src/lib/blas/ztrsm.f
deleted file mode 100644
index e414ec66..00000000
--- a/src/lib/blas/ztrsm.f
+++ /dev/null
@@ -1,414 +0,0 @@
- SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
- $ B, LDB )
-* .. Scalar Arguments ..
- CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
- INTEGER M, N, LDA, LDB
- COMPLEX*16 ALPHA
-* .. Array Arguments ..
- COMPLEX*16 A( LDA, * ), B( LDB, * )
-* ..
-*
-* Purpose
-* =======
-*
-* ZTRSM 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' or op( A ) = conjg( 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 ) = conjg( 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 - COMPLEX*16 .
-* 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 - COMPLEX*16 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 - COMPLEX*16 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.
-*
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* .. External Subroutines ..
- EXTERNAL XERBLA
-* .. Intrinsic Functions ..
- INTRINSIC DCONJG, MAX
-* .. Local Scalars ..
- LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER
- INTEGER I, INFO, J, K, NROWA
- COMPLEX*16 TEMP
-* .. Parameters ..
- COMPLEX*16 ONE
- PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
- COMPLEX*16 ZERO
- PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
-* ..
-* .. Executable Statements ..
-*
-* Test the input parameters.
-*
- LSIDE = LSAME( SIDE , 'L' )
- IF( LSIDE )THEN
- NROWA = M
- ELSE
- NROWA = N
- END IF
- NOCONJ = LSAME( TRANSA, 'T' )
- 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( 'ZTRSM ', INFO )
- RETURN
- END IF
-*
-* Quick return if possible.
-*
- IF( 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*inv( A )*B.
-*
- IF( UPPER )THEN
- DO 60, J = 1, N
- IF( ALPHA.NE.ONE )THEN
- DO 30, I = 1, M
- B( I, J ) = ALPHA*B( I, J )
- 30 CONTINUE
- END IF
- DO 50, K = M, 1, -1
- IF( B( K, J ).NE.ZERO )THEN
- IF( NOUNIT )
- $ B( K, J ) = B( K, J )/A( K, K )
- DO 40, I = 1, K - 1
- B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
- 40 CONTINUE
- END IF
- 50 CONTINUE
- 60 CONTINUE
- ELSE
- DO 100, J = 1, N
- IF( ALPHA.NE.ONE )THEN
- DO 70, I = 1, M
- B( I, J ) = ALPHA*B( I, J )
- 70 CONTINUE
- END IF
- DO 90 K = 1, M
- IF( B( K, J ).NE.ZERO )THEN
- IF( NOUNIT )
- $ B( K, J ) = B( K, J )/A( K, K )
- DO 80, I = K + 1, M
- B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
- 80 CONTINUE
- END IF
- 90 CONTINUE
- 100 CONTINUE
- END IF
- ELSE
-*
-* Form B := alpha*inv( A' )*B
-* or B := alpha*inv( conjg( A' ) )*B.
-*
- IF( UPPER )THEN
- DO 140, J = 1, N
- DO 130, I = 1, M
- TEMP = ALPHA*B( I, J )
- IF( NOCONJ )THEN
- DO 110, K = 1, I - 1
- TEMP = TEMP - A( K, I )*B( K, J )
- 110 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/A( I, I )
- ELSE
- DO 120, K = 1, I - 1
- TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J )
- 120 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/DCONJG( A( I, I ) )
- END IF
- B( I, J ) = TEMP
- 130 CONTINUE
- 140 CONTINUE
- ELSE
- DO 180, J = 1, N
- DO 170, I = M, 1, -1
- TEMP = ALPHA*B( I, J )
- IF( NOCONJ )THEN
- DO 150, K = I + 1, M
- TEMP = TEMP - A( K, I )*B( K, J )
- 150 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/A( I, I )
- ELSE
- DO 160, K = I + 1, M
- TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J )
- 160 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/DCONJG( A( I, I ) )
- END IF
- B( I, J ) = TEMP
- 170 CONTINUE
- 180 CONTINUE
- END IF
- END IF
- ELSE
- IF( LSAME( TRANSA, 'N' ) )THEN
-*
-* Form B := alpha*B*inv( A ).
-*
- IF( UPPER )THEN
- DO 230, J = 1, N
- IF( ALPHA.NE.ONE )THEN
- DO 190, I = 1, M
- B( I, J ) = ALPHA*B( I, J )
- 190 CONTINUE
- END IF
- DO 210, K = 1, J - 1
- IF( A( K, J ).NE.ZERO )THEN
- DO 200, I = 1, M
- B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
- 200 CONTINUE
- END IF
- 210 CONTINUE
- IF( NOUNIT )THEN
- TEMP = ONE/A( J, J )
- DO 220, I = 1, M
- B( I, J ) = TEMP*B( I, J )
- 220 CONTINUE
- END IF
- 230 CONTINUE
- ELSE
- DO 280, J = N, 1, -1
- IF( ALPHA.NE.ONE )THEN
- DO 240, I = 1, M
- B( I, J ) = ALPHA*B( I, J )
- 240 CONTINUE
- END IF
- DO 260, K = J + 1, N
- IF( A( K, J ).NE.ZERO )THEN
- DO 250, I = 1, M
- B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
- 250 CONTINUE
- END IF
- 260 CONTINUE
- IF( NOUNIT )THEN
- TEMP = ONE/A( J, J )
- DO 270, I = 1, M
- B( I, J ) = TEMP*B( I, J )
- 270 CONTINUE
- END IF
- 280 CONTINUE
- END IF
- ELSE
-*
-* Form B := alpha*B*inv( A' )
-* or B := alpha*B*inv( conjg( A' ) ).
-*
- IF( UPPER )THEN
- DO 330, K = N, 1, -1
- IF( NOUNIT )THEN
- IF( NOCONJ )THEN
- TEMP = ONE/A( K, K )
- ELSE
- TEMP = ONE/DCONJG( A( K, K ) )
- END IF
- DO 290, I = 1, M
- B( I, K ) = TEMP*B( I, K )
- 290 CONTINUE
- END IF
- DO 310, J = 1, K - 1
- IF( A( J, K ).NE.ZERO )THEN
- IF( NOCONJ )THEN
- TEMP = A( J, K )
- ELSE
- TEMP = DCONJG( A( J, K ) )
- END IF
- DO 300, I = 1, M
- B( I, J ) = B( I, J ) - TEMP*B( I, K )
- 300 CONTINUE
- END IF
- 310 CONTINUE
- IF( ALPHA.NE.ONE )THEN
- DO 320, I = 1, M
- B( I, K ) = ALPHA*B( I, K )
- 320 CONTINUE
- END IF
- 330 CONTINUE
- ELSE
- DO 380, K = 1, N
- IF( NOUNIT )THEN
- IF( NOCONJ )THEN
- TEMP = ONE/A( K, K )
- ELSE
- TEMP = ONE/DCONJG( A( K, K ) )
- END IF
- DO 340, I = 1, M
- B( I, K ) = TEMP*B( I, K )
- 340 CONTINUE
- END IF
- DO 360, J = K + 1, N
- IF( A( J, K ).NE.ZERO )THEN
- IF( NOCONJ )THEN
- TEMP = A( J, K )
- ELSE
- TEMP = DCONJG( A( J, K ) )
- END IF
- DO 350, I = 1, M
- B( I, J ) = B( I, J ) - TEMP*B( I, K )
- 350 CONTINUE
- END IF
- 360 CONTINUE
- IF( ALPHA.NE.ONE )THEN
- DO 370, I = 1, M
- B( I, K ) = ALPHA*B( I, K )
- 370 CONTINUE
- END IF
- 380 CONTINUE
- END IF
- END IF
- END IF
-*
- RETURN
-*
-* End of ZTRSM .
-*
- END
generated by cgit (git 2.34.1) at 2025-03-20 14:33:15 +0000