From c172b6118be01db8b230aa8b7a6a523c0aa6a8e3 Mon Sep 17 00:00:00 2001 From: Shreyas911 Date: Sun, 26 Jul 2026 09:41:44 -0500 Subject: [PATCH 1/6] docs: clarify BLAS library naming for CMake-built LAPACK Reference LAPACK's CMake build produces libblas.a/liblapack.a rather than librefblas.a, which the Make and Meson builds expect by default. Document the symlink/override workarounds. Tested (Make path only; Meson not installed locally): - Make + symlink (ln -s libblas.a librefblas.a): build succeeds - Make + BLAS_LIB override (BLAS_LIB="-L$LAPACKDIR -lblas"): build succeeds - Meson + -Dlibblas=blas -Dlibblas_path=$LAPACKDIR: build succeeds --- README.md | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 5e5700c..f4ba130 100644 --- a/README.md +++ b/README.md @@ -76,7 +76,7 @@ You need **pre-generated** sources (from step 1). The build compiles them and li **Dependencies:** - **Fortran compiler** (e.g. gfortran, ifort, ifx) and **C compiler** (e.g. gcc). -- **LAPACK installation** — a built Reference LAPACK (or compatible) providing BLAS (e.g. `librefblas.a` or `libblas.a`). Set **`LAPACKDIR`** (or equivalent) so Meson can find it (see below). +- **LAPACK installation** — a built Reference LAPACK (or compatible) providing BLAS (e.g. `librefblas.a` or `libblas.a`). Set **`LAPACKDIR`** (or equivalent) so Meson can find it (see below). If your build produced `libblas.a` rather than `librefblas.a`, pass `-Dlibblas=blas` instead of `-Dlibblas=refblas`. - **Tapenade adStack** — the repo already contains `TAPENADE/adStack.c` and `TAPENADE/include/`; Meson compiles and links these automatically. No separate Tapenade install is required for the build. **Configure and build from the project root:** @@ -119,6 +119,19 @@ export LAPACKDIR=/path/to/your/lapack/build # or wherever librefblas is make ``` +**Note on library naming:** if you built Reference LAPACK yourself via its standard CMake build, the resulting BLAS archive is usually named `libblas.a` (and `liblapack.a`), not `librefblas.a`. Since this Makefile links against `-lrefblas` by default (see `BLAS_LIB` in the Makefile), you'll need to either: + +1. Symlink it to the expected name: + + cd $LAPACKDIR + ln -s libblas.a librefblas.a + +2. Or override `BLAS_LIB` with the full linker flags for your archive's actual name: + + make BLAS_LIB="-L$LAPACKDIR -lblas" + +Run `find $LAPACKDIR -name "*.a"` first if you're not sure which archive names you actually have. + This builds per-mode static libraries (`build/libdiffblas_d.a`, `libdiffblas_b.a`, `libdiffblas_dv.a`, `libdiffblas_bv.a`) and test executables in `build/`. Run tests: ```bash From 5d88369e8d79a2fedab3c546eb3f0c48e67f95a0 Mon Sep 17 00:00:00 2001 From: Shreyas911 Date: Sun, 2 Aug 2026 14:44:54 -0500 Subject: [PATCH 2/6] Minor addition to README --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index f4ba130..5b145f9 100644 --- a/README.md +++ b/README.md @@ -116,7 +116,7 @@ meson install -C builddir --prefix /your/install ```bash cd BLAS export LAPACKDIR=/path/to/your/lapack/build # or wherever librefblas is -make +make # use make -j 8 or make -j 16 for a faster build using multi-threading ``` **Note on library naming:** if you built Reference LAPACK yourself via its standard CMake build, the resulting BLAS archive is usually named `libblas.a` (and `liblapack.a`), not `librefblas.a`. Since this Makefile links against `-lrefblas` by default (see `BLAS_LIB` in the Makefile), you'll need to either: From 102e12e9634c3fc8af68e566372ef17612fb6ea4 Mon Sep 17 00:00:00 2001 From: Shreyas911 Date: Sun, 2 Aug 2026 15:49:04 -0500 Subject: [PATCH 3/6] dtrsm correctly differentiated using Giles Method for all 4 modes. --- BLAS/src/dtrsm_b.f | 905 +++++++++++++++++++ BLAS/src/dtrsm_bv.f | 1054 +++++++++++++++++++++++ BLAS/src/dtrsm_d.f | 530 ++++++++++++ BLAS/src/dtrsm_dv.f | 637 ++++++++++++++ BLAS/test/test_dtrsm.f90 | 201 +++++ BLAS/test/test_dtrsm_reverse.f90 | 254 ++++++ BLAS/test/test_dtrsm_vector_forward.f90 | 180 ++++ BLAS/test/test_dtrsm_vector_reverse.f90 | 257 ++++++ 8 files changed, 4018 insertions(+) create mode 100644 BLAS/src/dtrsm_b.f create mode 100644 BLAS/src/dtrsm_bv.f create mode 100644 BLAS/src/dtrsm_d.f create mode 100644 BLAS/src/dtrsm_dv.f create mode 100644 BLAS/test/test_dtrsm.f90 create mode 100644 BLAS/test/test_dtrsm_reverse.f90 create mode 100644 BLAS/test/test_dtrsm_vector_forward.f90 create mode 100644 BLAS/test/test_dtrsm_vector_reverse.f90 diff --git a/BLAS/src/dtrsm_b.f b/BLAS/src/dtrsm_b.f new file mode 100644 index 0000000..79bbe86 --- /dev/null +++ b/BLAS/src/dtrsm_b.f @@ -0,0 +1,905 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of dtrsm in reverse (adjoint) mode: +C gradient of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:out a:out b:in-out +C> \brief \b DTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C DOUBLE PRECISION ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C DOUBLE PRECISION A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> DTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**T. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is DOUBLE PRECISION. +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is DOUBLE PRECISION array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is DOUBLE PRECISION array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE DTRSM_B(side, uplo, transa, diag, m, n, alpha, alphab, +C + a, ab, lda, b, bb, ldb) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C DOUBLE PRECISION alpha +C DOUBLE PRECISION alphab +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C DOUBLE PRECISION a(lda, *), b(ldb, *) +C DOUBLE PRECISION ab(lda, *), bb(ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +CC .. +CC .. Local Scalars .. +C DOUBLE PRECISION temp +C DOUBLE PRECISION tempb +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, nounit, upper +C INTEGER ISIZE2OFA +CC .. +CC .. Parameters .. +C DOUBLE PRECISION zero +C PARAMETER (zero=0.0d+0) +C INTEGER max1 +C INTEGER max2 +C DOUBLE PRECISION tempb0 +C DOUBLE PRECISION tmp +C DOUBLE PRECISION tmpb +C DOUBLE PRECISION tmp0 +C DOUBLE PRECISION tmpb0 +C DOUBLE PRECISION tmp1 +C DOUBLE PRECISION tmpb1 +C DOUBLE PRECISION tmp2 +C DOUBLE PRECISION tmpb2 +C DOUBLE PRECISION tmp3 +C DOUBLE PRECISION tmpb3 +C DOUBLE PRECISION tmp4 +C DOUBLE PRECISION tmpb4 +C INTEGER ad_to +C INTEGER*4 branch +C INTEGER ad_from +C INTEGER ad_to0 +C INTEGER ad_from0 +C INTEGER ad_to1 +C INTEGER ad_from1 +C INTEGER ad_to2 +C INTEGER ad_from2 +C INTEGER ii2 +C INTEGER ii1 +CC .. +CC +CC Test the input parameters. +CC +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE IF (m .LT. 0) THEN +C CALL PUSHCONTROL3B(4) +C info = 5 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(6) +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) THEN +C CALL PUSHCONTROL3B(7) +C info = 11 +C ELSE +C CALL PUSHCONTROL3B(7) +C END IF +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (m .EQ. 0 .OR. n .EQ. 0) THEN +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=n,1,-1 +C DO i=m,1,-1 +C bb(i, j) = 0.D0 +C ENDDO +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ELSE IF (lside) THEN +CC +CC Start the operations. +CC +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL8(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,k-1 +C tmp = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C ENDDO +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=1,m,1 +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C CALL POPREAL8(b(i, j)) +C tmpb = bb(i, j) +C bb(i, j) = tmpb +C bb(k, j) = bb(k, j) - a(i, k)*tmpb +C ab(i, k) = ab(i, k) - b(k, j)*tmpb +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPREAL8(b(k, j)) +C tempb0 = bb(k, j)/a(k, k) +C bb(k, j) = tempb0 +C ab(k, k) = ab(k, k) - b(k, j)*tempb0/a(k, k) +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C alphab = alphab + b(i, j)*bb(i, j) +C bb(i, j) = alpha*bb(i, j) +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C CALL PUSHREAL8(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from = k + 1 +C DO i=ad_from,m +C tmp0 = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp0 +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=m,1,-1 +C CALL POPINTEGER4(ad_from) +C DO i=m,ad_from,-1 +C CALL POPREAL8(b(i, j)) +C tmpb0 = bb(i, j) +C bb(i, j) = tmpb0 +C bb(k, j) = bb(k, j) - a(i, k)*tmpb0 +C ab(i, k) = ab(i, k) - b(k, j)*tmpb0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPREAL8(b(k, j)) +C tempb0 = bb(k, j)/a(k, k) +C bb(k, j) = tempb0 +C ab(k, k) = ab(k, k) - b(k, j)*tempb0/a(k, k) +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C alphab = alphab + b(i, j)*bb(i, j) +C bb(i, j) = alpha*bb(i, j) +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B. +CC +C DO j=1,n +C DO i=1,m +C temp = alpha*b(i, j) +C DO k=1,i-1 +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C tempb = bb(i, j) +C bb(i, j) = 0.D0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C tempb0 = tempb/a(i, i) +C tempb = tempb0 +C ab(i, i) = ab(i, i) - temp*tempb0/a(i, i) +C END IF +C CALL POPINTEGER4(ad_to0) +C DO k=ad_to0,1,-1 +C ab(k, i) = ab(k, i) - b(k, j)*tempb +C bb(k, j) = bb(k, j) - a(k, i)*tempb +C ENDDO +C alphab = alphab + b(i, j)*tempb +C bb(i, j) = bb(i, j) + alpha*tempb +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C temp = alpha*b(i, j) +C ad_from0 = i + 1 +C DO k=ad_from0,m +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=1,m,1 +C CALL POPREAL8(b(i, j)) +C tempb = bb(i, j) +C bb(i, j) = 0.D0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C tempb0 = tempb/a(i, i) +C tempb = tempb0 +C ab(i, i) = ab(i, i) - temp*tempb0/a(i, i) +C END IF +C CALL POPINTEGER4(ad_from0) +C DO k=m,ad_from0,-1 +C ab(k, i) = ab(k, i) - b(k, j)*tempb +C bb(k, j) = bb(k, j) - a(k, i)*tempb +C ENDDO +C alphab = alphab + b(i, j)*tempb +C bb(i, j) = bb(i, j) + alpha*tempb +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C tmp1 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp1 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C tempb0 = bb(i, j)/a(j, j) +C bb(i, j) = tempb0 +C ab(j, j) = ab(j, j) - b(i, j)*tempb0/a(j, j) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO k=ad_to1,1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C tmpb1 = bb(i, j) +C bb(i, j) = tmpb1 +C ab(k, j) = ab(k, j) - b(i, k)*tmpb1 +C bb(i, k) = bb(i, k) - a(k, j)*tmpb1 +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C alphab = alphab + b(i, j)*bb(i, j) +C bb(i, j) = alpha*bb(i, j) +C ENDDO +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C ad_from1 = j + 1 +C DO k=ad_from1,n +C DO i=1,m +C tmp2 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp2 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C tempb0 = bb(i, j)/a(j, j) +C bb(i, j) = tempb0 +C ab(j, j) = ab(j, j) - b(i, j)*tempb0/a(j, j) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from1) +C DO k=n,ad_from1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C tmpb2 = bb(i, j) +C bb(i, j) = tmpb2 +C ab(k, j) = ab(k, j) - b(i, k)*tmpb2 +C bb(i, k) = bb(i, k) - a(k, j)*tmpb2 +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C alphab = alphab + b(i, j)*bb(i, j) +C bb(i, j) = alpha*bb(i, j) +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL8(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO j=1,k-1 +C DO i=1,m +C tmp3 = b(i, j) - a(j, k)*b(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp3 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(j - 1) +C DO i=1,m +C CALL PUSHREAL8(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO k=1,n,1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, k)) +C alphab = alphab + b(i, k)*bb(i, k) +C bb(i, k) = alpha*bb(i, k) +C ENDDO +C CALL POPINTEGER4(ad_to2) +C DO j=ad_to2,1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C tmpb3 = bb(i, j) +C bb(i, j) = tmpb3 +C ab(j, k) = ab(j, k) - b(i, k)*tmpb3 +C bb(i, k) = bb(i, k) - a(j, k)*tmpb3 +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL8(b(i, k)) +C tempb0 = bb(i, k)/a(k, k) +C bb(i, k) = tempb0 +C ab(k, k) = ab(k, k) - b(i, k)*tempb0/a(k, k) +C ENDDO +C END IF +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL8(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from2 = k + 1 +C DO j=ad_from2,n +C DO i=1,m +C tmp4 = b(i, j) - a(j, k)*b(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp4 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C DO i=1,m +C CALL PUSHREAL8(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C alphab = 0.D0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO k=n,1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, k)) +C alphab = alphab + b(i, k)*bb(i, k) +C bb(i, k) = alpha*bb(i, k) +C ENDDO +C CALL POPINTEGER4(ad_from2) +C DO j=n,ad_from2,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C tmpb4 = bb(i, j) +C bb(i, j) = tmpb4 +C ab(j, k) = ab(j, k) - b(i, k)*tmpb4 +C bb(i, k) = bb(i, k) - a(j, k)*tmpb4 +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL8(b(i, k)) +C tempb0 = bb(i, k)/a(k, k) +C bb(i, k) = tempb0 +C ab(k, k) = ab(k, k) - b(i, k)*tempb0/a(k, k) +C ENDDO +C END IF +C ENDDO +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE DTRSM_B(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB) +C +C Reverse-mode (adjoint) derivative of DTRSM via the Giles/black-box +C method: differentiates op(A)*X = alpha*B directly, using only the +C original, undifferentiated DTRSM -- never the substitution algorithm. +C +C CONVENTION (matches Tapenade's own generated dtrsm_b.f): +C B : untouched, original forward-call input. +C BB : IN = seed adjoint dF/dX; OUT = adjoint dF/dB (in place). +C ALPHAB, AB : OUTPUT ONLY -- zeroed and filled here, not accumulated +C into whatever the caller passed in. +C + IMPLICIT NONE + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA, ALPHAB + DOUBLE PRECISION A(LDA,*), AB(LDA,*) + DOUBLE PRECISION B(LDB,*), BB(LDB,*) + + DOUBLE PRECISION X(M,N) + CHARACTER TRANSA_T + LOGICAL LEFT, UPPER, UNIT, NOTRANS + INTEGER I, J, K + + LEFT = (SIDE.EQ.'L' .OR. SIDE.EQ.'l') + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + NOTRANS = (TRANSA.EQ.'N' .OR. TRANSA.EQ.'n') + IF (NOTRANS) THEN + TRANSA_T = 'T' + ELSE + TRANSA_T = 'N' + END IF + + IF (M.EQ.0 .OR. N.EQ.0) THEN + ALPHAB = 0.0D0 + RETURN + END IF + +C Step 1: Yb solves op(A)^T*Yb = Xb (SIDE='L') or Yb*op(A)^T = Xb (SIDE='R'). +C Overwrites BB in place: held the seed on entry, holds Yb after. + CALL DTRSM(SIDE, UPLO, TRANSA_T, DIAG, M, N, 1.0D0, A, LDA, BB, LDB) + +C Step 2: recompute X from the ORIGINAL, untouched B + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL DTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + +C Step 3: alphab = (ORIGINAL B, not X) + ALPHAB = 0.0D0 + DO J = 1, N + DO I = 1, M + ALPHAB = ALPHAB + BB(I,J)*B(I,J) + END DO + END DO + +C Step 4: Ab, restricted to the triangle DTRSM actually reads + DO J = 1, LDA + DO I = 1, LDA + AB(I,J) = 0.0D0 + END DO + END DO + + IF (LEFT) THEN + DO J = 1, M + DO I = 1, M + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + DO K = 1, N + AB(I,J) = AB(I,J) - BB(I,K)*X(J,K) + END DO + ELSE + DO K = 1, N + AB(I,J) = AB(I,J) - X(I,K)*BB(J,K) + END DO + END IF + END IF + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + DO K = 1, M + AB(I,J) = AB(I,J) - X(K,I)*BB(K,J) + END DO + ELSE + DO K = 1, M + AB(I,J) = AB(I,J) - BB(K,I)*X(K,J) + END DO + END IF + END IF + END IF + END DO + END DO + END IF + +C Step 5: Bb = alpha * Yb (BB currently holds Yb from Step 1) + DO J = 1, N + DO I = 1, M + BB(I,J) = ALPHA*BB(I,J) + END DO + END DO + + RETURN + END SUBROUTINE DTRSM_B diff --git a/BLAS/src/dtrsm_bv.f b/BLAS/src/dtrsm_bv.f new file mode 100644 index 0000000..694e6b2 --- /dev/null +++ b/BLAS/src/dtrsm_bv.f @@ -0,0 +1,1054 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of dtrsm in reverse (adjoint) mode (with options multiDirectional): +C gradient of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:out a:out b:in-out +C> \brief \b DTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C DOUBLE PRECISION ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C DOUBLE PRECISION A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> DTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**T. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is DOUBLE PRECISION. +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is DOUBLE PRECISION array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is DOUBLE PRECISION array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE DTRSM_BV(side, uplo, transa, diag, m, n, alpha, alphab +C + , a, ab, lda, b, bb, ldb, nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C DOUBLE PRECISION alpha +C DOUBLE PRECISION alphab(nbdirsmax) +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C DOUBLE PRECISION a(lda, *), b(ldb, *) +C DOUBLE PRECISION ab(nbdirsmax, lda, *), bb(nbdirsmax, ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +CC .. +CC .. Local Scalars .. +C DOUBLE PRECISION temp +C DOUBLE PRECISION tempb(nbdirsmax) +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, nounit, upper +C INTEGER ISIZE2OFA +CC .. +CC .. Parameters .. +C DOUBLE PRECISION zero +C PARAMETER (zero=0.0d+0) +C INTEGER max1 +C INTEGER max2 +C INTEGER nd +C DOUBLE PRECISION tempb0(nbdirsmax) +C DOUBLE PRECISION tmp +C DOUBLE PRECISION tmpb(nbdirsmax) +C DOUBLE PRECISION tmp0 +C DOUBLE PRECISION tmpb0(nbdirsmax) +C DOUBLE PRECISION tmp1 +C DOUBLE PRECISION tmpb1(nbdirsmax) +C DOUBLE PRECISION tmp2 +C DOUBLE PRECISION tmpb2(nbdirsmax) +C DOUBLE PRECISION tmp3 +C DOUBLE PRECISION tmpb3(nbdirsmax) +C DOUBLE PRECISION tmp4 +C DOUBLE PRECISION tmpb4(nbdirsmax) +C INTEGER ad_to +C INTEGER*4 branch +C INTEGER ad_from +C INTEGER ad_to0 +C INTEGER ad_from0 +C INTEGER ad_to1 +C INTEGER ad_from1 +C INTEGER ad_to2 +C INTEGER ad_from2 +C INTEGER ii2 +C INTEGER ii1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE IF (m .LT. 0) THEN +C CALL PUSHCONTROL3B(4) +C info = 5 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(6) +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) THEN +C CALL PUSHCONTROL3B(7) +C info = 11 +C ELSE +C CALL PUSHCONTROL3B(7) +C END IF +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (m .EQ. 0 .OR. n .EQ. 0) THEN +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=n,1,-1 +C DO i=m,1,-1 +C DO nd=1,nbdirs +C bb(nd, i, j) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C ELSE IF (lside) THEN +CC +CC Start the operations. +CC +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL8(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,k-1 +C tmp = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=1,m,1 +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tmpb(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb(nd) +C bb(nd, k, j) = bb(nd, k, j) - a(i, k)*tmpb(nd) +C ab(nd, i, k) = ab(nd, i, k) - b(k, j)*tmpb(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPREAL8(b(k, j)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, k, j)/a(k, k) +C bb(nd, k, j) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) - b(k, j)*tempb0(nd)/a +C + (k, k) +C ENDDO +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*bb(nd, i, j) +C bb(nd, i, j) = alpha*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C CALL PUSHREAL8(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from = k + 1 +C DO i=ad_from,m +C tmp0 = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp0 +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=m,1,-1 +C CALL POPINTEGER4(ad_from) +C DO i=m,ad_from,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tmpb0(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb0(nd) +C bb(nd, k, j) = bb(nd, k, j) - a(i, k)*tmpb0(nd) +C ab(nd, i, k) = ab(nd, i, k) - b(k, j)*tmpb0(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPREAL8(b(k, j)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, k, j)/a(k, k) +C bb(nd, k, j) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) - b(k, j)*tempb0(nd)/a +C + (k, k) +C ENDDO +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*bb(nd, i, j) +C bb(nd, i, j) = alpha*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B. +CC +C DO j=1,n +C DO i=1,m +C temp = alpha*b(i, j) +C DO k=1,i-1 +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tempb(nd) = bb(nd, i, j) +C bb(nd, i, j) = 0.D0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, i, i) = ab(nd, i, i) - temp*tempb0(nd)/a(i, i +C + ) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to0) +C DO k=ad_to0,1,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) - b(k, j)*tempb(nd) +C bb(nd, k, j) = bb(nd, k, j) - a(k, i)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*tempb(nd) +C bb(nd, i, j) = bb(nd, i, j) + alpha*tempb(nd) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C temp = alpha*b(i, j) +C ad_from0 = i + 1 +C DO k=ad_from0,m +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=1,m,1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tempb(nd) = bb(nd, i, j) +C bb(nd, i, j) = 0.D0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, i, i) = ab(nd, i, i) - temp*tempb0(nd)/a(i, i +C + ) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from0) +C DO k=m,ad_from0,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) - b(k, j)*tempb(nd) +C bb(nd, k, j) = bb(nd, k, j) - a(k, i)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*tempb(nd) +C bb(nd, i, j) = bb(nd, i, j) + alpha*tempb(nd) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C tmp1 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp1 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, i, j)/a(j, j) +C bb(nd, i, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - b(i, j)*tempb0(nd)/a(j +C + , j) +C ENDDO +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO k=ad_to1,1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tmpb1(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb1(nd) +C ab(nd, k, j) = ab(nd, k, j) - b(i, k)*tmpb1(nd) +C bb(nd, i, k) = bb(nd, i, k) - a(k, j)*tmpb1(nd) +C ENDDO +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*bb(nd, i, j) +C bb(nd, i, j) = alpha*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C ad_from1 = j + 1 +C DO k=ad_from1,n +C DO i=1,m +C tmp2 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp2 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, i, j)/a(j, j) +C bb(nd, i, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - b(i, j)*tempb0(nd)/a(j +C + , j) +C ENDDO +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from1) +C DO k=n,ad_from1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tmpb2(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb2(nd) +C ab(nd, k, j) = ab(nd, k, j) - b(i, k)*tmpb2(nd) +C bb(nd, i, k) = bb(nd, i, k) - a(k, j)*tmpb2(nd) +C ENDDO +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*bb(nd, i, j) +C bb(nd, i, j) = alpha*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL8(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO j=1,k-1 +C DO i=1,m +C tmp3 = b(i, j) - a(j, k)*b(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp3 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(j - 1) +C DO i=1,m +C CALL PUSHREAL8(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO k=1,n,1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, k)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, k)*bb(nd, i, k) +C bb(nd, i, k) = alpha*bb(nd, i, k) +C ENDDO +C ENDDO +C CALL POPINTEGER4(ad_to2) +C DO j=ad_to2,1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tmpb3(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb3(nd) +C ab(nd, j, k) = ab(nd, j, k) - b(i, k)*tmpb3(nd) +C bb(nd, i, k) = bb(nd, i, k) - a(j, k)*tmpb3(nd) +C ENDDO +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL8(b(i, k)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, i, k)/a(k, k) +C bb(nd, i, k) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) - b(i, k)*tempb0(nd)/a(k, +C + k) +C ENDDO +C ENDDO +C END IF +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL8(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from2 = k + 1 +C DO j=ad_from2,n +C DO i=1,m +C tmp4 = b(i, j) - a(j, k)*b(i, k) +C CALL PUSHREAL8(b(i, j)) +C b(i, j) = tmp4 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C DO i=1,m +C CALL PUSHREAL8(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.D0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO k=n,1,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, k)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, k)*bb(nd, i, k) +C bb(nd, i, k) = alpha*bb(nd, i, k) +C ENDDO +C ENDDO +C CALL POPINTEGER4(ad_from2) +C DO j=n,ad_from2,-1 +C DO i=m,1,-1 +C CALL POPREAL8(b(i, j)) +C DO nd=1,nbdirs +C tmpb4(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb4(nd) +C ab(nd, j, k) = ab(nd, j, k) - b(i, k)*tmpb4(nd) +C bb(nd, i, k) = bb(nd, i, k) - a(j, k)*tmpb4(nd) +C ENDDO +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL8(b(i, k)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, i, k)/a(k, k) +C bb(nd, i, k) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) - b(i, k)*tempb0(nd)/a(k, +C + k) +C ENDDO +C ENDDO +C END IF +C ENDDO +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE DTRSM_BV(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB, NBDIRS) +C +C Vector reverse-mode (adjoint) derivative of DTRSM, black-box/Giles-style. +C Self-contained -- does not call DTRSM_B. AB/BB store direction as the +C FASTEST-varying index (nbdirsmax, LDA/LDB, *): gather each direction into +C a plain work array before use, scatter the result back after. +C +C CONVENTION (matches Tapenade's dtrsm_bv.f): +C B : untouched, original forward-call input. +C BB : IN = seed adjoints (one per direction); OUT = dF/dB. +C ALPHAB, AB : OUTPUT ONLY, zeroed and filled here per direction. +C + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB, NBDIRS + DOUBLE PRECISION ALPHA + DOUBLE PRECISION ALPHAB(NBDIRSMAX) + DOUBLE PRECISION A(LDA,*), AB(NBDIRSMAX,LDA,*) + DOUBLE PRECISION B(LDB,*), BB(NBDIRSMAX,LDB,*) + + DOUBLE PRECISION X(M,N) + DOUBLE PRECISION BB_SLICE(LDB,N), AB_SLICE(LDA,LDA) + CHARACTER TRANSA_T + LOGICAL LEFT, UPPER, UNIT, NOTRANS + INTEGER ND, I, J, K + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + LEFT = (SIDE.EQ.'L' .OR. SIDE.EQ.'l') + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + NOTRANS = (TRANSA.EQ.'N' .OR. TRANSA.EQ.'n') + IF (NOTRANS) THEN + TRANSA_T = 'T' + ELSE + TRANSA_T = 'N' + END IF + + IF (M.EQ.0 .OR. N.EQ.0) THEN + DO ND = 1, NBDIRS + ALPHAB(ND) = 0.0D0 + END DO + RETURN + END IF + +C X = solution of the original forward call (same for every direction) + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL DTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO ND = 1, NBDIRS + +C Gather this direction's seed out of the interleaved BB layout + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = BB(ND,I,J) + END DO + END DO + +C Step 1: Yb solves op(A)^T*Yb = Xb (overwrites BB_SLICE in place) + CALL DTRSM(SIDE, UPLO, TRANSA_T, DIAG, M, N, 1.0D0, + + A, LDA, BB_SLICE, LDB) + +C Step 2: alphab(nd) = (ORIGINAL B, not X) + ALPHAB(ND) = 0.0D0 + DO J = 1, N + DO I = 1, M + ALPHAB(ND) = ALPHAB(ND) + BB_SLICE(I,J)*B(I,J) + END DO + END DO + +C Step 3: Ab for this direction, restricted to the triangle read + DO J = 1, LDA + DO I = 1, LDA + AB_SLICE(I,J) = 0.0D0 + END DO + END DO + + IF (LEFT) THEN + DO J = 1, M + DO I = 1, M + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - BB_SLICE(I,K)*X(J,K) + END DO + ELSE + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - X(I,K)*BB_SLICE(J,K) + END DO + END IF + END IF + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - X(K,I)*BB_SLICE(K,J) + END DO + ELSE + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - BB_SLICE(K,I)*X(K,J) + END DO + END IF + END IF + END IF + END DO + END DO + END IF + +C Step 4: Bb = alpha * Yb (BB_SLICE currently holds Yb) + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = ALPHA*BB_SLICE(I,J) + END DO + END DO + +C Scatter this direction's results back into the interleaved layout + DO J = 1, LDA + DO I = 1, LDA + AB(ND,I,J) = AB_SLICE(I,J) + END DO + END DO + DO J = 1, N + DO I = 1, M + BB(ND,I,J) = BB_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE DTRSM_BV + diff --git a/BLAS/src/dtrsm_d.f b/BLAS/src/dtrsm_d.f new file mode 100644 index 0000000..da09d20 --- /dev/null +++ b/BLAS/src/dtrsm_d.f @@ -0,0 +1,530 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of dtrsm in forward (tangent) mode: +C variations of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:in a:in b:in-out +C> \brief \b DTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C DOUBLE PRECISION ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C DOUBLE PRECISION A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> DTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**T. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is DOUBLE PRECISION. +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is DOUBLE PRECISION array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is DOUBLE PRECISION array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE DTRSM_D(side, uplo, transa, diag, m, n, alpha, alphad, +C + a, ad, lda, b, bd, ldb) +C IMPLICIT NONE +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C DOUBLE PRECISION alpha +C DOUBLE PRECISION alphad +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C DOUBLE PRECISION a(lda, *), b(ldb, *) +C DOUBLE PRECISION ad(lda, *), bd(ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +CC .. +CC .. Local Scalars .. +C DOUBLE PRECISION temp +C DOUBLE PRECISION tempd +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, nounit, upper +CC .. +CC .. Parameters .. +C DOUBLE PRECISION zero +C PARAMETER (zero=0.0d+0) +C INTEGER max1 +C INTEGER max2 +C DOUBLE PRECISION temp0 +CC .. +CC +CC Test the input parameters. +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 4 +C ELSE IF (m .LT. 0) THEN +C info = 5 +C ELSE IF (n .LT. 0) THEN +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) info = 11 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('DTRSM ', info) +C RETURN +C ELSE IF (m .EQ. 0 .OR. n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=1,n +C DO i=1,m +C bd(i, j) = 0.D0 +C b(i, j) = zero +C ENDDO +C ENDDO +C RETURN +C ELSE +CC +CC Start the operations. +CC +C IF (lside) THEN +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C bd(k, j) = (bd(k, j)-temp0*ad(k, k))/a(k, k) +C b(k, j) = temp0 +C END IF +C DO i=1,k-1 +C bd(i, j) = bd(i, j) - a(i, k)*bd(k, j) - b(k, j)*ad( +C + i, k) +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C bd(k, j) = (bd(k, j)-temp0*ad(k, k))/a(k, k) +C b(k, j) = temp0 +C END IF +C DO i=k+1,m +C bd(i, j) = bd(i, j) - a(i, k)*bd(k, j) - b(k, j)*ad( +C + i, k) +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B. +CC +C DO j=1,n +C DO i=1,m +C tempd = b(i, j)*alphad + alpha*bd(i, j) +C temp = alpha*b(i, j) +C DO k=1,i-1 +C tempd = tempd - b(k, j)*ad(k, i) - a(k, i)*bd(k, j) +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C tempd = (tempd-temp0*ad(i, i))/a(i, i) +C temp = temp0 +C END IF +C bd(i, j) = tempd +C b(i, j) = temp +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C tempd = b(i, j)*alphad + alpha*bd(i, j) +C temp = alpha*b(i, j) +C DO k=i+1,m +C tempd = tempd - b(k, j)*ad(k, i) - a(k, i)*bd(k, j) +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C tempd = (tempd-temp0*ad(i, i))/a(i, i) +C temp = temp0 +C END IF +C bd(i, j) = tempd +C b(i, j) = temp +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(k, j) - a(k, j)*bd(i +C + , k) +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C bd(i, j) = (bd(i, j)-temp0*ad(j, j))/a(j, j) +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=j+1,n +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(k, j) - a(k, j)*bd(i +C + , k) +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C bd(i, j) = (bd(i, j)-temp0*ad(j, j))/a(j, j) +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C bd(i, k) = (bd(i, k)-temp0*ad(k, k))/a(k, k) +C b(i, k) = temp0 +C ENDDO +C END IF +C DO j=1,k-1 +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(j, k) - a(j, k)*bd(i, k +C + ) +C b(i, j) = b(i, j) - a(j, k)*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C bd(i, k) = b(i, k)*alphad + alpha*bd(i, k) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C bd(i, k) = (bd(i, k)-temp0*ad(k, k))/a(k, k) +C b(i, k) = temp0 +C ENDDO +C END IF +C DO j=k+1,n +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(j, k) - a(j, k)*bd(i, k +C + ) +C b(i, j) = b(i, j) - a(j, k)*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C bd(i, k) = b(i, k)*alphad + alpha*bd(i, k) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C END IF +CC +C RETURN +CC +CC End of DTRSM +CC +C END IF +C END SUBROUTINE DTRSM_D + + SUBROUTINE DTRSM_D(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB) +C +C Forward-mode derivative of DTRSM via the black-box / Giles-style +C approach: uses ONLY the original, undifferentiated +C DTRSM and DTRMM -- no hand-differentiated loops. +C + IMPLICIT NONE + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA, ALPHAD + DOUBLE PRECISION A(LDA,*), AD(LDA,*) + DOUBLE PRECISION B(LDB,*), BD(LDB,*) + + DOUBLE PRECISION X(M,N), T(M,N) + INTEGER I, J + + IF (M.EQ.0 .OR. N.EQ.0) RETURN + +C Step 1: X = solution of the original forward call +C (private copy -- B itself must stay untouched) + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL DTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + +C Step 2: T = op(Ad)*X (SIDE='L') or X*op(Ad) (SIDE='R') + DO J = 1, N + DO I = 1, M + T(I,J) = X(I,J) + END DO + END DO + CALL DTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, 1.0D0, AD, LDA, T, M) + +C Step 3: build RHS = alphad*B + alpha*Bd - T, in place in BD + DO J = 1, N + DO I = 1, M + BD(I,J) = ALPHAD*B(I,J) + ALPHA*BD(I,J) - T(I,J) + END DO + END DO + +C Step 4: solve the SAME triangular system again -> dX, overwrites BD + CALL DTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, 1.0D0, A, LDA, BD, LDB) + + RETURN + END SUBROUTINE DTRSM_D + diff --git a/BLAS/src/dtrsm_dv.f b/BLAS/src/dtrsm_dv.f new file mode 100644 index 0000000..9c91a3e --- /dev/null +++ b/BLAS/src/dtrsm_dv.f @@ -0,0 +1,637 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of dtrsm in forward (tangent) mode (with options multiDirectional): +C variations of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:in a:in b:in-out +C> \brief \b DTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C DOUBLE PRECISION ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C DOUBLE PRECISION A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> DTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**T. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is DOUBLE PRECISION. +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is DOUBLE PRECISION array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is DOUBLE PRECISION array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE DTRSM_DV(side, uplo, transa, diag, m, n, alpha, alphad +C + , a, ad, lda, b, bd, ldb, nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C DOUBLE PRECISION alpha +C DOUBLE PRECISION alphad(nbdirsmax) +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C DOUBLE PRECISION a(lda, *), b(ldb, *) +C DOUBLE PRECISION ad(nbdirsmax, lda, *), bd(nbdirsmax, ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +CC .. +CC .. Local Scalars .. +C DOUBLE PRECISION temp +C DOUBLE PRECISION tempd(nbdirsmax) +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, nounit, upper +CC .. +CC .. Parameters .. +C DOUBLE PRECISION zero +C PARAMETER (zero=0.0d+0) +C INTEGER max1 +C INTEGER max2 +C INTEGER nd +C DOUBLE PRECISION temp0 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 4 +C ELSE IF (m .LT. 0) THEN +C info = 5 +C ELSE IF (n .LT. 0) THEN +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) info = 11 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('DTRSM ', info) +C RETURN +C ELSE IF (m .EQ. 0 .OR. n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = 0.D0 +C ENDDO +C b(i, j) = zero +C ENDDO +C ENDDO +C RETURN +C ELSE +CC +CC Start the operations. +CC +C IF (lside) THEN +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, +C + j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, k, j) = (bd(nd, k, j)-temp0*ad(nd, k, k))/a +C + (k, k) +C ENDDO +C b(k, j) = temp0 +C END IF +C DO i=1,k-1 +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - a(i, k)*bd(nd, k, j) +C + - b(k, j)*ad(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, +C + j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, k, j) = (bd(nd, k, j)-temp0*ad(nd, k, k))/a +C + (k, k) +C ENDDO +C b(k, j) = temp0 +C END IF +C DO i=k+1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - a(i, k)*bd(nd, k, j) +C + - b(k, j)*ad(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B. +CC +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C tempd(nd) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C temp = alpha*b(i, j) +C DO k=1,i-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*ad(nd, k, i) - a(k, +C + i)*bd(nd, k, j) +C ENDDO +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, i, i))/a(i, i) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C bd(nd, i, j) = tempd(nd) +C ENDDO +C b(i, j) = temp +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C temp = alpha*b(i, j) +C DO k=i+1,m +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*ad(nd, k, i) - a(k, +C + i)*bd(nd, k, j) +C ENDDO +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, i, i))/a(i, i) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C bd(nd, i, j) = tempd(nd) +C ENDDO +C b(i, j) = temp +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, k, j) - +C + a(k, j)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C DO nd=1,nbdirs +C bd(nd, i, j) = (bd(nd, i, j)-temp0*ad(nd, j, j))/a(j +C + , j) +C ENDDO +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=j+1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, k, j) - +C + a(k, j)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C DO nd=1,nbdirs +C bd(nd, i, j) = (bd(nd, i, j)-temp0*ad(nd, j, j))/a(j +C + , j) +C ENDDO +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*ad(nd, k, k))/a(k, +C + k) +C ENDDO +C b(i, k) = temp0 +C ENDDO +C END IF +C DO j=1,k-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, j, k) - a +C + (j, k)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(j, k)*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, k) = b(i, k)*alphad(nd) + alpha*bd(nd, i, k) +C ENDDO +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*ad(nd, k, k))/a(k, +C + k) +C ENDDO +C b(i, k) = temp0 +C ENDDO +C END IF +C DO j=k+1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, j, k) - a +C + (j, k)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(j, k)*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, k) = b(i, k)*alphad(nd) + alpha*bd(nd, i, k) +C ENDDO +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C END IF +CC +C RETURN +CC +CC End of DTRSM +CC +C END IF +C END + + SUBROUTINE DTRSM_DV(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB, NBDIRS) +C +C Vector forward-mode derivative of DTRSM (black-box / Giles-style): +C differentiates op(A)*X = alpha*B directly, using only the original +C DTRSM and DTRMM. Self-contained, does not call DTRSM_D. +C +C AD/BD store direction as the FASTEST-varying index (nbdirsmax, LDA/LDB, *), +C so each direction's slice is gathered into a plain work array before use. +C + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB, NBDIRS + DOUBLE PRECISION ALPHA + DOUBLE PRECISION ALPHAD(NBDIRSMAX) + DOUBLE PRECISION A(LDA,*), AD(NBDIRSMAX,LDA,*) + DOUBLE PRECISION B(LDB,*), BD(NBDIRSMAX,LDB,*) + + DOUBLE PRECISION X(M,N), T(M,N) + DOUBLE PRECISION AD_SLICE(LDA,N), BD_SLICE(LDB,N) + INTEGER ND, I, J + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (M.EQ.0 .OR. N.EQ.0) RETURN + +C X = solution of the original forward call (same for every direction) + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL DTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO ND = 1, NBDIRS + +C Gather this direction out of the interleaved AD/BD layout + DO J = 1, N + DO I = 1, M + AD_SLICE(I,J) = AD(ND,I,J) + BD_SLICE(I,J) = BD(ND,I,J) + END DO + END DO + +C T = op(Ad)*X (SIDE='L') or X*op(Ad) (SIDE='R') + DO J = 1, N + DO I = 1, M + T(I,J) = X(I,J) + END DO + END DO + CALL DTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, 1.0D0, + + AD_SLICE, LDA, T, M) + +C RHS = alphad*B + alpha*Bd - T, built in place in BD_SLICE + DO J = 1, N + DO I = 1, M + BD_SLICE(I,J) = ALPHAD(ND)*B(I,J) + ALPHA*BD_SLICE(I,J) + + - T(I,J) + END DO + END DO + +C Solve the same triangular system again -> dX for this direction + CALL DTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, 1.0D0, + + A, LDA, BD_SLICE, LDB) + +C Scatter the result back into the interleaved layout + DO J = 1, N + DO I = 1, M + BD(ND,I,J) = BD_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE DTRSM_DV diff --git a/BLAS/test/test_dtrsm.f90 b/BLAS/test/test_dtrsm.f90 new file mode 100644 index 0000000..11ada7b --- /dev/null +++ b/BLAS/test/test_dtrsm.f90 @@ -0,0 +1,201 @@ +! Test program for DTRSM differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision + +program test_dtrsm + implicit none + + integer :: seed_array(33) + + external :: dtrsm + external :: dtrsm_d + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + real(8) :: alpha + real(8), dimension(max_size,max_size) :: a + integer :: lda_val + real(8), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Derivative variables + real(8) :: alpha_d + real(8), dimension(max_size,max_size) :: a_d + real(8), dimension(max_size,max_size) :: b_d + + ! Storage variables for inout parameters + real(8), dimension(max_size,max_size) :: b_output + + ! Array restoration variables for numerical differentiation + real(8) :: alpha_orig + real(8), dimension(max_size,max_size) :: b_orig + real(8), dimension(max_size,max_size) :: a_orig + + ! Variables for central difference computation + real(8), dimension(max_size,max_size) :: b_forward, b_backward + ! Scalar variables for central difference computation + real(8) :: central_diff, ad_result + logical :: has_large_errors + + ! Variables for storing original derivative values + real(8) :: alpha_d_orig + real(8), dimension(max_size,max_size) :: b_d_orig + real(8), dimension(max_size,max_size) :: a_d_orig + + ! Temporary variables for matrix initialization + real(4) :: temp_real, temp_imag + integer :: i, j + + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(alpha) + alpha = alpha * 2.0d0 - 1.0d0 ! Scale to [-1,1] + call random_number(a) + a = a * 2.0d0 - 1.0d0 ! Scale to [-1,1] + lda_val = lda ! LDA must be at least max( 1 + call random_number(b) + b = b * 2.0d0 - 1.0d0 ! Scale to [-1,1] + ldb_val = ldb + + ! Initialize input derivatives to random values + call random_number(alpha_d) + alpha_d = alpha_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + call random_number(b_d) + b_d = b_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + call random_number(a_d) + a_d = a_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + + ! Store initial derivative values after random initialization + alpha_d_orig = alpha_d + b_d_orig = b_d + a_d_orig = a_d + + ! Store original values for central difference computation + alpha_orig = alpha + b_orig = b + a_orig = a + + write(*,*) 'Testing DTRSM' + ! Store input values of inout parameters before first function call + b_orig = b + + ! Re-initialize data for differentiated function + ! Only reinitialize inout parameters - keep input-only parameters unchanged + + ! side already has correct value from original call + ! uplo already has correct value from original call + ! transa already has correct value from original call + ! diag already has correct value from original call + msize = n + nsize = n + ! alpha already has correct value from original call + ! a already has correct value from original call + lda_val = lda ! LDA must be at least max( 1 + b = b_orig + ldb_val = ldb + + ! Call the differentiated function + call dtrsm_d(side, uplo, transa, diag, msize, nsize, alpha, alpha_d, a, a_d, lda_val, b, b_d, ldb_val) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(8), parameter :: h = 1.0e-6 ! Step size for finite differences + real(8) :: relative_error, max_error + real(8) :: output_orig, output_pert + real(8) :: numerical_result, analytical_result + real(8) :: abs_error, abs_reference, error_bound + integer :: i, j + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5 + + ! Original values already stored in main program + + ! Central difference computation: f(x + h) - f(x - h) / (2h) + ! Forward perturbation: f(x + h) + alpha = alpha_orig + h * alpha_d_orig + b = b_orig + h * b_d_orig + a = a_orig + h * a_d_orig + call dtrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + ! Store forward perturbation results + b_forward = b + + ! Backward perturbation: f(x - h) + alpha = alpha_orig - h * alpha_d_orig + b = b_orig - h * b_d_orig + a = a_orig - h * a_d_orig + call dtrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + ! Store backward perturbation results + b_backward = b + + ! Compute central differences and compare with AD results + ! Check derivatives for output B + do j = 1, min(2, n) ! Check only first few elements + do i = 1, min(2, n) + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (b_forward(i,j) - b_backward(i,j)) / (2.0e0 * h) + ! AD result + ad_result = b_d(i,j) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) 'Large error in output B(', i, ',', j, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_dtrsm diff --git a/BLAS/test/test_dtrsm_reverse.f90 b/BLAS/test/test_dtrsm_reverse.f90 new file mode 100644 index 0000000..ebe5cb7 --- /dev/null +++ b/BLAS/test/test_dtrsm_reverse.f90 @@ -0,0 +1,254 @@ +! Test program for DTRSM reverse mode (adjoint) differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision +! Verification uses VJP methodology with finite differences + +program test_dtrsm_reverse + implicit none + + integer :: seed_array(33) + + external :: dtrsm + external :: dtrsm_b + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + real(8) :: alpha + real(8), dimension(max_size,max_size) :: a + integer :: lda_val + real(8), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Adjoint variables (reverse mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + real(8) :: alphab + real(8), dimension(max_size,max_size) :: ab + real(8), dimension(max_size,max_size) :: bb + + ! Storage for original values (for VJP verification) + real(8) :: alpha_orig + real(8), dimension(max_size,max_size) :: a_orig + real(8), dimension(max_size,max_size) :: b_orig + + ! Variables for VJP verification via finite differences + real(8), dimension(max_size,max_size) :: b_plus, b_minus + + ! Saved cotangents (output adjoints) for VJP verification + real(8), dimension(max_size,max_size) :: bb_orig + real(8), parameter :: h = 1.0e-7 + real(8) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + integer :: i, j + real(8), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + ! Initialize primal values + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(alpha) + alpha = alpha * 2.0d0 - 1.0d0 + call random_number(a) + a = a * 2.0d0 - 1.0d0 + lda_val = lda + call random_number(b) + b = b * 2.0d0 - 1.0d0 + ldb_val = ldb + + ! Store original primal values + alpha_orig = alpha + a_orig = a + b_orig = b + + write(*,*) 'Testing DTRSM' + + ! Initialize output adjoints (cotangents) with random values + ! These are the 'seeds' for reverse mode + call random_number(bb) + bb = bb * 2.0d0 - 1.0d0 + + ! Save output adjoints (cotangents) for VJP verification + ! Note: output adjoints may be modified by reverse mode function + bb_orig = bb + + ! Initialize input adjoints to zero (they will be computed) + ab = 0.0d0 + alphab = 0.0d0 + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! Differentiated code checks they are set via check_ISIZE*_initialized. + call set_ISIZE2OFA(max_size) + + ! Call reverse mode differentiated function + call dtrsm_b(side, uplo, transa, diag, msize, nsize, alpha, alphab, a, ab, lda_val, b, bb, ldb_val) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + ! For reverse mode, we verify: cotangent^T @ J @ direction = direction^T @ adjoint + ! Equivalently: cotangent^T @ (f(x+h*dir) - f(x-h*dir))/(2h) should equal dir^T @ computed_adjoint + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing (like tangents in forward mode) + real(8) :: alpha_dir + real(8), dimension(max_size,max_size) :: a_dir + real(8), dimension(max_size,max_size) :: b_dir + + real(8), dimension(max_size,max_size) :: b_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Initialize random direction vectors for all inputs + call random_number(alpha_dir) + alpha_dir = alpha_dir * 2.0d0 - 1.0d0 + call random_number(a_dir) + a_dir = a_dir * 2.0d0 - 1.0d0 + call random_number(b_dir) + b_dir = b_dir * 2.0d0 - 1.0d0 + + ! Forward perturbation: f(x + h*dir) + alpha = alpha_orig + h * alpha_dir + a = a_orig + h * a_dir + b = b_orig + h * b_dir + call dtrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_plus = b + + ! Backward perturbation: f(x - h*dir) + alpha = alpha_orig - h * alpha_dir + a = a_orig - h * a_dir + b = b_orig - h * b_dir + call dtrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_minus = b + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + b_central_diff = (b_plus - b_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0d0 + ! Compute and sort products for b (FD) + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = bb_orig(i,j) * b_central_diff(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0d0 + vjp_ad = vjp_ad + alpha_dir * alphab + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = a_dir(i,j) * ab(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for b + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = b_dir(i,j) * bb(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + max_error = relative_error + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(8), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(8) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_dtrsm_reverse diff --git a/BLAS/test/test_dtrsm_vector_forward.f90 b/BLAS/test/test_dtrsm_vector_forward.f90 new file mode 100644 index 0000000..5e8404a --- /dev/null +++ b/BLAS/test/test_dtrsm_vector_forward.f90 @@ -0,0 +1,180 @@ +! Test program for DTRSM vector forward mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision with nbdirsmax=4 + +program test_dtrsm_vector_forward + implicit none + include 'DIFFSIZES.inc' + + external :: dtrsm + external :: dtrsm_dv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, idir ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + real(8) :: alpha + real(8), dimension(max_size,max_size) :: a + integer :: lda_val + real(8), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Vector mode derivative variables (type-promoted) + ! Scalars become arrays(nbdirsmax), arrays gain extra dimension + real(8), dimension(nbdirsmax) :: alpha_dv + real(8), dimension(nbdirsmax,max_size,max_size) :: a_dv + real(8), dimension(nbdirsmax,max_size,max_size) :: b_dv + ! Declare variables for storing original values + real(8) :: alpha_orig + real(8), dimension(nbdirsmax) :: alpha_dv_orig + real(8), dimension(max_size,max_size) :: a_orig + real(8), dimension(nbdirsmax,max_size,max_size) :: a_dv_orig + real(8), dimension(max_size,max_size) :: b_orig + real(8), dimension(nbdirsmax,max_size,max_size) :: b_dv_orig + + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize test parameters + msize = n + nsize = n + lda_val = lda + ldb_val = ldb + + ! Initialize test data with random numbers + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + call random_number(alpha) + alpha = alpha * 2.0d0 - 1.0d0 ! Scale to [-1,1] + call random_number(a) + a = a * 2.0d0 - 1.0d0 ! Scale to [-1,1] + call random_number(b) + b = b * 2.0d0 - 1.0d0 ! Scale to [-1,1] + + ! Initialize input derivatives to random values (exactly like scalar mode) + do idir = 1, nbdirsmax + call random_number(temp_real) + alpha_dv(idir) = temp_real * 2.0d0 - 1.0d0 + end do + do idir = 1, nbdirsmax + call random_number(a_dv(idir,:,:)) + a_dv(idir,:,:) = a_dv(idir,:,:) * 2.0d0 - 1.0d0 + end do + do idir = 1, nbdirsmax + call random_number(b_dv(idir,:,:)) + b_dv(idir,:,:) = b_dv(idir,:,:) * 2.0d0 - 1.0d0 + end do + + write(*,*) 'Testing DTRSM (Vector Forward Mode)' + ! Store original values before any function calls (critical for INOUT parameters) + alpha_orig = alpha + alpha_dv_orig = alpha_dv + a_orig = a + a_dv_orig = a_dv + b_orig = b + b_dv_orig = b_dv + + ! Call the vector mode differentiated function + + call dtrsm_dv(side, uplo, transa, diag, msize, nsize, alpha, alpha_dv, a, a_dv, lda_val, b, b_dv, ldb_val, nbdirsmax) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Vector forward mode test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(8), parameter :: h = 1.0e-7 ! Step size for finite differences + real(8) :: relative_error, max_error + real(8) :: abs_error, abs_reference, error_bound + real(8) :: central_diff, ad_result + integer :: i, j, idir + logical :: has_large_errors + real(8), dimension(max_size,max_size) :: b_forward, b_backward + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + write(*,*) 'Number of directions:', nbdirsmax + + ! Test each derivative direction separately + do idir = 1, nbdirsmax + + ! Forward perturbation: f(x + h * direction) + alpha = alpha_orig + h * alpha_dv_orig(idir) + a = a_orig + h * a_dv_orig(idir,:,:) + b = b_orig + h * b_dv_orig(idir,:,:) + call dtrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_forward = b + + ! Backward perturbation: f(x - h * direction) + alpha = alpha_orig - h * alpha_dv_orig(idir) + a = a_orig - h * a_dv_orig(idir,:,:) + b = b_orig - h * b_dv_orig(idir,:,:) + call dtrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_backward = b + + ! Compute central differences and compare with AD results + do j = 1, min(2, nsize) ! Check only first few elements + do i = 1, min(2, nsize) + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (b_forward(i,j) - b_backward(i,j)) / (2.0e0 * h) + ! AD result + ad_result = b_dv(idir,i,j) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) ' Large error in direction', idir, ' output B(', i, ',', j, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_dtrsm_vector_forward \ No newline at end of file diff --git a/BLAS/test/test_dtrsm_vector_reverse.f90 b/BLAS/test/test_dtrsm_vector_reverse.f90 new file mode 100644 index 0000000..748d90e --- /dev/null +++ b/BLAS/test/test_dtrsm_vector_reverse.f90 @@ -0,0 +1,257 @@ +! Test program for DTRSM vector reverse mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision with nbdirsmax=4 + +program test_dtrsm_vector_reverse + implicit none + include 'DIFFSIZES.inc' + + external :: dtrsm + external :: dtrsm_bv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, k ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + real(8) :: alpha + real(8), dimension(max_size,max_size) :: a + integer :: lda_val + real(8), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Adjoint variables (reverse vector mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + real(8), dimension(nbdirsmax) :: alphab + real(8), dimension(nbdirsmax,max_size,max_size) :: ab + real(8), dimension(nbdirsmax,max_size,max_size) :: bb + + ! Storage for original cotangents (for INOUT parameters in VJP verification) + real(8), dimension(nbdirsmax,max_size,max_size) :: bb_orig + + ! Storage for original values (for VJP verification) + real(8) :: alpha_orig + real(8), dimension(max_size,max_size) :: a_orig + real(8), dimension(max_size,max_size) :: b_orig + + ! Variables for VJP verification via finite differences + real(8), parameter :: h = 1.0e-7 + real(8) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + real(8), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + ! Initialize primal values + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(alpha) + alpha = alpha * 2.0 - 1.0 + call random_number(a) + a = a * 2.0 - 1.0 + lda_val = lda + call random_number(b) + b = b * 2.0 - 1.0 + ldb_val = ldb + + ! Store original primal values + alpha_orig = alpha + a_orig = a + b_orig = b + + ! Initialize output adjoints (cotangents) with random values for each direction + ! These are the 'seeds' for reverse mode + do k = 1, nbdirsmax + call random_number(bb(k,:,:)) + bb(k,:,:) = bb(k,:,:) * 2.0 - 1.0 + end do + + ! Initialize input adjoints to zero (they will be computed) + ! Note: Inout parameters are skipped - they already have output adjoints initialized + alphab = 0.0 + ab = 0.0 + + ! Save original cotangent seeds for OUTPUT/INOUT parameters (before function call) + bb_orig = bb + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! ISIZE1OF* (vectors): use n to match adjoint array size; ISIZE2OF* (matrices): use max_size. + call set_ISIZE2OFA(max_size) + + ! Call reverse vector mode differentiated function + call dtrsm_bv(side, uplo, transa, diag, msize, nsize, alpha, alphab, a, ab, lda_val, b, bb, ldb_val, nbdirsmax) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing + real(8) :: alpha_dir + real(8), dimension(max_size,max_size) :: a_dir + real(8), dimension(max_size,max_size) :: b_dir + real(8), dimension(max_size,max_size) :: b_plus, b_minus, b_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Test each differentiation direction separately + do k = 1, nbdirsmax + + ! Initialize random direction vectors for all inputs + call random_number(alpha_dir) + alpha_dir = alpha_dir * 2.0 - 1.0 + call random_number(a_dir) + a_dir = a_dir * 2.0 - 1.0 + call random_number(b_dir) + b_dir = b_dir * 2.0 - 1.0 + + ! Forward perturbation: f(x + h*dir) + alpha = alpha_orig + h * alpha_dir + a = a_orig + h * a_dir + b = b_orig + h * b_dir + call dtrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_plus = b + + ! Backward perturbation: f(x - h*dir) + alpha = alpha_orig - h * alpha_dir + a = a_orig - h * a_dir + b = b_orig - h * b_dir + call dtrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_minus = b + + ! Compute central differences and VJP verification + ! VJP check: direction^T @ adjoint should equal finite difference + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + b_central_diff = (b_plus - b_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0d0 + ! Compute and sort products for b (FD) + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = bb_orig(k,i,j) * b_central_diff(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0d0 + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = a_dir(i,j) * ab(k,i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for b + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = b_dir(i,j) * bb(k,i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + vjp_ad = vjp_ad + alpha_dir * alphab(k) + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + ! Compute relative error for reporting + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + if (relative_error > max_error) max_error = relative_error + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(8), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(8) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_dtrsm_vector_reverse From bf9b1477df314e8677b585cc0ee8a9d36cffe55f Mon Sep 17 00:00:00 2001 From: Shreyas911 Date: Sun, 23 Aug 2026 16:14:42 -0500 Subject: [PATCH 4/6] dtrsv, strsv, strsm correctly differentiated using Giles Method for all 4 modes. --- BLAS/src/dtrsm_d.f | 2 +- BLAS/src/dtrsv_b.f | 721 ++++++++++++++++ BLAS/src/dtrsv_bv.f | 831 ++++++++++++++++++ BLAS/src/dtrsv_d.f | 442 ++++++++++ BLAS/src/dtrsv_dv.f | 533 ++++++++++++ BLAS/src/strsm_b.f | 903 +++++++++++++++++++ BLAS/src/strsm_bv.f | 1047 +++++++++++++++++++++++ BLAS/src/strsm_d.f | 529 ++++++++++++ BLAS/src/strsm_dv.f | 636 ++++++++++++++ BLAS/src/strsv_b.f | 651 ++++++++++++++ BLAS/src/strsv_bv.f | 746 ++++++++++++++++ BLAS/src/strsv_d.f | 397 +++++++++ BLAS/src/strsv_dv.f | 473 ++++++++++ BLAS/test/test_dtrsv.f90 | 180 ++++ BLAS/test/test_dtrsv_reverse.f90 | 231 +++++ BLAS/test/test_dtrsv_vector_forward.f90 | 160 ++++ BLAS/test/test_dtrsv_vector_reverse.f90 | 235 +++++ BLAS/test/test_strsm.f90 | 201 +++++ BLAS/test/test_strsm_reverse.f90 | 255 ++++++ BLAS/test/test_strsm_vector_forward.f90 | 180 ++++ BLAS/test/test_strsm_vector_reverse.f90 | 258 ++++++ BLAS/test/test_strsv.f90 | 180 ++++ BLAS/test/test_strsv_reverse.f90 | 231 +++++ BLAS/test/test_strsv_vector_forward.f90 | 160 ++++ BLAS/test/test_strsv_vector_reverse.f90 | 235 +++++ 25 files changed, 10416 insertions(+), 1 deletion(-) create mode 100644 BLAS/src/dtrsv_b.f create mode 100644 BLAS/src/dtrsv_bv.f create mode 100644 BLAS/src/dtrsv_d.f create mode 100644 BLAS/src/dtrsv_dv.f create mode 100644 BLAS/src/strsm_b.f create mode 100644 BLAS/src/strsm_bv.f create mode 100644 BLAS/src/strsm_d.f create mode 100644 BLAS/src/strsm_dv.f create mode 100644 BLAS/src/strsv_b.f create mode 100644 BLAS/src/strsv_bv.f create mode 100644 BLAS/src/strsv_d.f create mode 100644 BLAS/src/strsv_dv.f create mode 100644 BLAS/test/test_dtrsv.f90 create mode 100644 BLAS/test/test_dtrsv_reverse.f90 create mode 100644 BLAS/test/test_dtrsv_vector_forward.f90 create mode 100644 BLAS/test/test_dtrsv_vector_reverse.f90 create mode 100644 BLAS/test/test_strsm.f90 create mode 100644 BLAS/test/test_strsm_reverse.f90 create mode 100644 BLAS/test/test_strsm_vector_forward.f90 create mode 100644 BLAS/test/test_strsm_vector_reverse.f90 create mode 100644 BLAS/test/test_strsv.f90 create mode 100644 BLAS/test/test_strsv_reverse.f90 create mode 100644 BLAS/test/test_strsv_vector_forward.f90 create mode 100644 BLAS/test/test_strsv_vector_reverse.f90 diff --git a/BLAS/src/dtrsm_d.f b/BLAS/src/dtrsm_d.f index da09d20..9757b5b 100644 --- a/BLAS/src/dtrsm_d.f +++ b/BLAS/src/dtrsm_d.f @@ -477,7 +477,7 @@ CC End of DTRSM CC C END IF -C END SUBROUTINE DTRSM_D +C END SUBROUTINE DTRSM_D(SIDE, UPLO, TRANSA, DIAG, M, N, + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB) diff --git a/BLAS/src/dtrsv_b.f b/BLAS/src/dtrsv_b.f new file mode 100644 index 0000000..bf569d8 --- /dev/null +++ b/BLAS/src/dtrsv_b.f @@ -0,0 +1,721 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of dtrsv in reverse (adjoint) mode: +C gradient of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:out +C> \brief \b DTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C DOUBLE PRECISION A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> DTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**T*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is DOUBLE PRECISION array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is DOUBLE PRECISION array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C ===================================================================== +C SUBROUTINE DTRSV_B(uplo, trans, diag, n, a, ab, lda, x, xb, incx) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C DOUBLE PRECISION a(lda, *), x(*) +C DOUBLE PRECISION ab(lda, *), xb(*) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C DOUBLE PRECISION temp +C DOUBLE PRECISION tempb +C INTEGER i, info, ix, j, jx, kx +C LOGICAL nounit +C EXTERNAL LSAME +C INTEGER ISIZE2OFA +CC .. +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +C INTEGER max1 +C DOUBLE PRECISION tempb0 +C INTEGER ad_from +C INTEGER*4 branch +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_from2 +C INTEGER ad_to +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_to2 +C INTEGER ii2 +C INTEGER ii1 +CC .. +CC +CC Test the input parameters. +CC +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(4) +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 8 +C ELSE +C CALL PUSHCONTROL3B(5) +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (n .EQ. 0) THEN +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ELSE +CC +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C CALL PUSHCONTROL1B(0) +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C CALL PUSHCONTROL1B(1) +C kx = 1 +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL8(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(temp) +C temp = x(j) +C ad_from = j - 1 +C DO i=ad_from,1,-1 +C CALL PUSHREAL8(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C tempb = 0.D0 +C CALL POPINTEGER4(ad_from) +C DO i=1,ad_from,1 +C CALL POPREAL8(x(i)) +C tempb = tempb - a(i, j)*xb(i) +C ab(i, j) = ab(i, j) - temp*xb(i) +C ENDDO +C CALL POPREAL8(temp) +C xb(j) = xb(j) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(x(j)) +C tempb0 = xb(j)/a(j, j) +C xb(j) = tempb0 +C ab(j, j) = ab(j, j) - x(j)*tempb0/a(j, j) +C END IF +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL8(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from0 = j - 1 +C DO i=ad_from0,1,-1 +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C CALL PUSHREAL8(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C tempb = 0.D0 +C CALL POPINTEGER4(ad_from0) +C DO i=1,ad_from0,1 +C CALL POPREAL8(x(ix)) +C tempb = tempb - a(i, j)*xb(ix) +C ab(i, j) = ab(i, j) - temp*xb(ix) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPREAL8(temp) +C xb(jx) = xb(jx) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(x(jx)) +C tempb0 = xb(jx)/a(j, j) +C xb(jx) = tempb0 +C ab(j, j) = ab(j, j) - x(jx)*tempb0/a(j, j) +C END IF +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHREAL8(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(temp) +C temp = x(j) +C ad_from1 = j + 1 +C DO i=ad_from1,n +C CALL PUSHREAL8(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C tempb = 0.D0 +C CALL POPINTEGER4(ad_from1) +C DO i=n,ad_from1,-1 +C CALL POPREAL8(x(i)) +C tempb = tempb - a(i, j)*xb(i) +C ab(i, j) = ab(i, j) - temp*xb(i) +C ENDDO +C CALL POPREAL8(temp) +C xb(j) = xb(j) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(x(j)) +C tempb0 = xb(j)/a(j, j) +C xb(j) = tempb0 +C ab(j, j) = ab(j, j) - x(j)*tempb0/a(j, j) +C END IF +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHREAL8(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from2 = j + 1 +C DO i=ad_from2,n +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C CALL PUSHREAL8(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C tempb = 0.D0 +C CALL POPINTEGER4(ad_from2) +C DO i=n,ad_from2,-1 +C CALL POPREAL8(x(ix)) +C tempb = tempb - a(i, j)*xb(ix) +C ab(i, j) = ab(i, j) - temp*xb(ix) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPREAL8(temp) +C xb(jx) = xb(jx) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(x(jx)) +C tempb0 = xb(jx)/a(j, j) +C xb(jx) = tempb0 +C ab(j, j) = ab(j, j) - x(jx)*tempb0/a(j, j) +C END IF +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C temp = x(j) +C DO i=1,j-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPREAL8(x(j)) +C tempb = xb(j) +C xb(j) = 0.D0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C tempb0 = tempb/a(j, j) +C tempb = tempb0 +C ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) +C END IF +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C ab(i, j) = ab(i, j) - x(i)*tempb +C xb(i) = xb(i) - a(i, j)*tempb +C ENDDO +C xb(j) = xb(j) + tempb +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C temp = x(jx) +C ix = kx +C DO i=1,j-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C CALL POPREAL8(x(jx)) +C tempb = xb(jx) +C xb(jx) = 0.D0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C tempb0 = tempb/a(j, j) +C tempb = tempb0 +C ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) +C END IF +C CALL POPINTEGER4(ad_to0) +C DO i=ad_to0,1,-1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) - x(ix)*tempb +C xb(ix) = xb(ix) - a(i, j)*tempb +C ENDDO +C xb(jx) = xb(jx) + tempb +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C temp = x(j) +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPREAL8(x(j)) +C tempb = xb(j) +C xb(j) = 0.D0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C tempb0 = tempb/a(j, j) +C tempb = tempb0 +C ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) +C END IF +C CALL POPINTEGER4(ad_to1) +C DO i=ad_to1,n,1 +C ab(i, j) = ab(i, j) - x(i)*tempb +C xb(i) = xb(i) - a(i, j)*tempb +C ENDDO +C xb(j) = xb(j) + tempb +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C temp = x(jx) +C ix = kx +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C CALL POPREAL8(x(jx)) +C tempb = xb(jx) +C xb(jx) = 0.D0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C tempb0 = tempb/a(j, j) +C tempb = tempb0 +C ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) +C END IF +C CALL POPINTEGER4(ad_to2) +C DO i=ad_to2,n,1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) - x(ix)*tempb +C xb(ix) = xb(ix) - a(i, j)*tempb +C ENDDO +C xb(jx) = xb(jx) + tempb +C ENDDO +C END IF +C CALL POPCONTROL1B(branch) +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE DTRSV_B(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, INCX) +! +! Reverse-mode (adjoint) derivative of DTRSV, black-box/Giles-style. +! X is read-only (original entry RHS), never written -- matches the +! net externally-visible behavior of Tapenade's own dtrsv_b.f. +! + IMPLICIT NONE + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX + DOUBLE PRECISION A(LDA,*), AB(LDA,*) + DOUBLE PRECISION X(*), XB(*) + + DOUBLE PRECISION BLOC(N), S(N), YB(N) + CHARACTER TRANS_T + LOGICAL UPPER, UNIT, NOTRANS + INTEGER I, J, KX + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + NOTRANS = (TRANS.EQ.'N' .OR. TRANS.EQ.'n') + IF (NOTRANS) THEN + TRANS_T = 'T' + ELSE + TRANS_T = 'N' + END IF + + DO I = 1, N + BLOC(I) = X(KX + (I-1)*INCX) + YB(I) = XB(KX + (I-1)*INCX) + END DO + +C Yb solves op(A)^T*Yb = Xb + CALL DTRSV(UPLO, TRANS_T, DIAG, N, A, LDA, YB, 1) + +C Recompute S from the original, untouched B + DO I = 1, N + S(I) = BLOC(I) + END DO + CALL DTRSV(UPLO, TRANS, DIAG, N, A, LDA, S, 1) + + DO J = 1, LDA + DO I = 1, LDA + AB(I,J) = 0.0D0 + END DO + END DO + + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + AB(I,J) = -YB(I)*S(J) + ELSE + AB(I,J) = -S(I)*YB(J) + END IF + END IF + END IF + END DO + END DO + +C Bb = Yb (no alpha in TRSV) + DO I = 1, N + XB(KX + (I-1)*INCX) = YB(I) + END DO + + RETURN + END SUBROUTINE DTRSV_B + diff --git a/BLAS/src/dtrsv_bv.f b/BLAS/src/dtrsv_bv.f new file mode 100644 index 0000000..903bf2c --- /dev/null +++ b/BLAS/src/dtrsv_bv.f @@ -0,0 +1,831 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of dtrsv in reverse (adjoint) mode (with options multiDirectional): +C gradient of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:out +C> \brief \b DTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C DOUBLE PRECISION A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> DTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**T*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is DOUBLE PRECISION array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is DOUBLE PRECISION array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C ===================================================================== +C SUBROUTINE DTRSV_BV(uplo, trans, diag, n, a, ab, lda, x, xb, incx +C + , nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C DOUBLE PRECISION a(lda, *), x(*) +C DOUBLE PRECISION ab(nbdirsmax, lda, *), xb(nbdirsmax, *) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C DOUBLE PRECISION temp +C DOUBLE PRECISION tempb(nbdirsmax) +C INTEGER i, info, ix, j, jx, kx +C LOGICAL nounit +C EXTERNAL LSAME +C INTEGER ISIZE2OFA +CC .. +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +C INTEGER max1 +C INTEGER nd +C DOUBLE PRECISION tempb0(nbdirsmax) +C INTEGER ad_from +C INTEGER*4 branch +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_from2 +C INTEGER ad_to +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_to2 +C INTEGER ii2 +C INTEGER ii1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(4) +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 8 +C ELSE +C CALL PUSHCONTROL3B(5) +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (n .EQ. 0) THEN +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C ELSE +CC +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C CALL PUSHCONTROL1B(0) +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C CALL PUSHCONTROL1B(1) +C kx = 1 +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL8(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(temp) +C temp = x(j) +C ad_from = j - 1 +C DO i=ad_from,1,-1 +C CALL PUSHREAL8(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C DO nd=1,nbdirsmax +C tempb(nd) = 0.D0 +C ENDDO +C CALL POPINTEGER4(ad_from) +C DO i=1,ad_from,1 +C CALL POPREAL8(x(i)) +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) - a(i, j)*xb(nd, i) +C ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, i) +C ENDDO +C ENDDO +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(x(j)) +C DO nd=1,nbdirs +C tempb0(nd) = xb(nd, j)/a(j, j) +C xb(nd, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - x(j)*tempb0(nd)/a(j +C + , j) +C ENDDO +C END IF +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL8(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from0 = j - 1 +C DO i=ad_from0,1,-1 +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C CALL PUSHREAL8(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C DO nd=1,nbdirsmax +C tempb(nd) = 0.D0 +C ENDDO +C CALL POPINTEGER4(ad_from0) +C DO i=1,ad_from0,1 +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) - a(i, j)*xb(nd, ix) +C ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, ix) +C ENDDO +C CALL POPREAL8(x(ix)) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(x(jx)) +C DO nd=1,nbdirs +C tempb0(nd) = xb(nd, jx)/a(j, j) +C xb(nd, jx) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - x(jx)*tempb0(nd)/a(j +C + , j) +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHREAL8(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(temp) +C temp = x(j) +C ad_from1 = j + 1 +C DO i=ad_from1,n +C CALL PUSHREAL8(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO nd=1,nbdirsmax +C tempb(nd) = 0.D0 +C ENDDO +C CALL POPINTEGER4(ad_from1) +C DO i=n,ad_from1,-1 +C CALL POPREAL8(x(i)) +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) - a(i, j)*xb(nd, i) +C ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, i) +C ENDDO +C ENDDO +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(x(j)) +C DO nd=1,nbdirs +C tempb0(nd) = xb(nd, j)/a(j, j) +C xb(nd, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - x(j)*tempb0(nd)/a(j, j +C + ) +C ENDDO +C END IF +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHREAL8(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from2 = j + 1 +C DO i=ad_from2,n +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C CALL PUSHREAL8(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C DO nd=1,nbdirsmax +C tempb(nd) = 0.D0 +C ENDDO +C CALL POPINTEGER4(ad_from2) +C DO i=n,ad_from2,-1 +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) - a(i, j)*xb(nd, ix) +C ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, ix) +C ENDDO +C CALL POPREAL8(x(ix)) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(x(jx)) +C DO nd=1,nbdirs +C tempb0(nd) = xb(nd, jx)/a(j, j) +C xb(nd, jx) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - x(jx)*tempb0(nd)/a(j, +C + j) +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C temp = x(j) +C DO i=1,j-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPREAL8(x(j)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, j) +C xb(nd, j) = 0.D0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j +C + ) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) - x(i)*tempb(nd) +C xb(nd, i) = xb(nd, i) - a(i, j)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C temp = x(jx) +C ix = kx +C DO i=1,j-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C CALL POPREAL8(x(jx)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, jx) +C xb(nd, jx) = 0.D0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j +C + ) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to0) +C DO i=ad_to0,1,-1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) - x(ix)*tempb(nd) +C xb(nd, ix) = xb(nd, ix) - a(i, j)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C temp = x(j) +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPREAL8(x(j)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, j) +C xb(nd, j) = 0.D0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO i=ad_to1,n,1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) - x(i)*tempb(nd) +C xb(nd, i) = xb(nd, i) - a(i, j)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C temp = x(jx) +C ix = kx +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHREAL8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL8(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.D0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C CALL POPREAL8(x(jx)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, jx) +C xb(nd, jx) = 0.D0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to2) +C DO i=ad_to2,n,1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) - x(ix)*tempb(nd) +C xb(nd, ix) = xb(nd, ix) - a(i, j)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C ENDDO +C END IF +C CALL POPCONTROL1B(branch) +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE DTRSV_BV(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, + + INCX, NBDIRS) +! +! Vector reverse-mode (adjoint) derivative of DTRSV, black-box/Giles-style. +! Self-contained -- does not call DTRSV_B. +! + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX, NBDIRS + DOUBLE PRECISION A(LDA,*), AB(NBDIRSMAX,LDA,*) + DOUBLE PRECISION X(*), XB(NBDIRSMAX,*) + + DOUBLE PRECISION BLOC(N), S(N), YB(N), AB_SLICE(LDA,LDA) + CHARACTER TRANS_T + LOGICAL UPPER, UNIT, NOTRANS + INTEGER ND, I, J, KX + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + NOTRANS = (TRANS.EQ.'N' .OR. TRANS.EQ.'n') + IF (NOTRANS) THEN + TRANS_T = 'T' + ELSE + TRANS_T = 'N' + END IF + +C Gather original B once, recompute S once (shared across directions) + DO I = 1, N + BLOC(I) = X(KX + (I-1)*INCX) + END DO + DO I = 1, N + S(I) = BLOC(I) + END DO + CALL DTRSV(UPLO, TRANS, DIAG, N, A, LDA, S, 1) + + DO ND = 1, NBDIRS + + DO I = 1, N + YB(I) = XB(ND, KX + (I-1)*INCX) + END DO + + CALL DTRSV(UPLO, TRANS_T, DIAG, N, A, LDA, YB, 1) + + DO J = 1, LDA + DO I = 1, LDA + AB_SLICE(I,J) = 0.0D0 + END DO + END DO + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + AB_SLICE(I,J) = -YB(I)*S(J) + ELSE + AB_SLICE(I,J) = -S(I)*YB(J) + END IF + END IF + END IF + END DO + END DO + + DO I = 1, N + XB(ND, KX + (I-1)*INCX) = YB(I) + END DO + DO J = 1, LDA + DO I = 1, LDA + AB(ND,I,J) = AB_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE DTRSV_BV + diff --git a/BLAS/src/dtrsv_d.f b/BLAS/src/dtrsv_d.f new file mode 100644 index 0000000..ca9ee5f --- /dev/null +++ b/BLAS/src/dtrsv_d.f @@ -0,0 +1,442 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of dtrsv in forward (tangent) mode: +C variations of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:in +C> \brief \b DTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C DOUBLE PRECISION A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> DTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**T*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is DOUBLE PRECISION array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is DOUBLE PRECISION array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C ===================================================================== +C SUBROUTINE DTRSV_D(uplo, trans, diag, n, a, ad, lda, x, xd, incx) +C IMPLICIT NONE +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C DOUBLE PRECISION a(lda, *), x(*) +C DOUBLE PRECISION ad(lda, *), xd(*) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C DOUBLE PRECISION temp +C DOUBLE PRECISION tempd +C INTEGER i, info, ix, j, jx, kx +C LOGICAL nounit +C EXTERNAL LSAME +CC .. +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +C INTEGER max1 +C DOUBLE PRECISION temp0 +CC .. +CC +CC Test the input parameters. +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 3 +C ELSE IF (n .LT. 0) THEN +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C info = 8 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('DTRSV ', info) +C RETURN +C ELSE IF (n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE +CC +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C kx = 1 +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) +C x(j) = temp0 +C END IF +C tempd = xd(j) +C temp = x(j) +C DO i=j-1,1,-1 +C xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) +C x(jx) = temp0 +C END IF +C tempd = xd(jx) +C temp = x(jx) +C ix = jx +C DO i=j-1,1,-1 +C ix = ix - incx +C xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx - incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) +C x(j) = temp0 +C END IF +C tempd = xd(j) +C temp = x(j) +C DO i=j+1,n +C xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) +C x(jx) = temp0 +C END IF +C tempd = xd(jx) +C temp = x(jx) +C ix = jx +C DO i=j+1,n +C ix = ix + incx +C xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C tempd = xd(j) +C temp = x(j) +C DO i=1,j-1 +C tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C xd(j) = tempd +C x(j) = temp +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C tempd = xd(jx) +C temp = x(jx) +C ix = kx +C DO i=1,j-1 +C tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) +C temp = temp - a(i, j)*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C xd(jx) = tempd +C x(jx) = temp +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C tempd = xd(j) +C temp = x(j) +C DO i=n,j+1,-1 +C tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C xd(j) = tempd +C x(j) = temp +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C tempd = xd(jx) +C temp = x(jx) +C ix = kx +C DO i=n,j+1,-1 +C tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) +C temp = temp - a(i, j)*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C xd(jx) = tempd +C x(jx) = temp +C jx = jx - incx +C ENDDO +C END IF +CC +C RETURN +CC +CC End of DTRSV +CC +C END IF +C END + + SUBROUTINE DTRSV_D(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, INCX) +! +! Forward-mode derivative of DTRSV, black-box/Giles-style: differentiate +! op(A)*s = b directly. Uses only the original DTRSV and DTRMV. +! X, XD are overwritten in place with the solution and its derivative, +! matching the primal DTRSV's own convention. +! + IMPLICIT NONE + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX + DOUBLE PRECISION A(LDA,*), AD(LDA,*) + DOUBLE PRECISION X(*), XD(*) + + DOUBLE PRECISION S(N), W(N) + INTEGER I, KX + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + +C Solve for S, overwriting X in place + CALL DTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + DO I = 1, N + S(I) = X(KX + (I-1)*INCX) + END DO + +C T = op(Ad)*S (local copy, unit stride) + DO I = 1, N + W(I) = S(I) + END DO + CALL DTRMV(UPLO, TRANS, DIAG, N, AD, LDA, W, 1) + +C RHS = Xd_in - T + DO I = 1, N + W(I) = XD(KX + (I-1)*INCX) - W(I) + END DO + +C Solve op(A)*dS = RHS -> W holds dS + CALL DTRSV(UPLO, TRANS, DIAG, N, A, LDA, W, 1) + + DO I = 1, N + XD(KX + (I-1)*INCX) = W(I) + END DO + + RETURN + END SUBROUTINE DTRSV_D + diff --git a/BLAS/src/dtrsv_dv.f b/BLAS/src/dtrsv_dv.f new file mode 100644 index 0000000..4d803aa --- /dev/null +++ b/BLAS/src/dtrsv_dv.f @@ -0,0 +1,533 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of dtrsv in forward (tangent) mode (with options multiDirectional): +C variations of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:in +C> \brief \b DTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C DOUBLE PRECISION A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> DTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**T*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is DOUBLE PRECISION array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is DOUBLE PRECISION array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C ===================================================================== +C SUBROUTINE DTRSV_DV(uplo, trans, diag, n, a, ad, lda, x, xd, incx +C + , nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C DOUBLE PRECISION a(lda, *), x(*) +C DOUBLE PRECISION ad(nbdirsmax, lda, *), xd(nbdirsmax, *) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C DOUBLE PRECISION temp +C DOUBLE PRECISION tempd(nbdirsmax) +C INTEGER i, info, ix, j, jx, kx +C LOGICAL nounit +C EXTERNAL LSAME +CC .. +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +C INTEGER max1 +C INTEGER nd +C DOUBLE PRECISION temp0 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 3 +C ELSE IF (n .LT. 0) THEN +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C info = 8 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('DTRSV ', info) +C RETURN +C ELSE IF (n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE +CC +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C kx = 1 +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(j) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=j-1,1,-1 +C DO nd=1,nbdirs +C xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad( +C + nd, i, j) +C ENDDO +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(jx) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = jx +C DO i=j-1,1,-1 +C ix = ix - incx +C DO nd=1,nbdirs +C xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp* +C + ad(nd, i, j) +C ENDDO +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx - incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(j) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=j+1,n +C DO nd=1,nbdirs +C xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad(nd +C + , i, j) +C ENDDO +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(jx) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = jx +C DO i=j+1,n +C ix = ix + incx +C DO nd=1,nbdirs +C xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp*ad( +C + nd, i, j) +C ENDDO +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=1,j-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd +C + (nd, i) +C ENDDO +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C xd(nd, j) = tempd(nd) +C ENDDO +C x(j) = temp +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = kx +C DO i=1,j-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)* +C + xd(nd, ix) +C ENDDO +C temp = temp - a(i, j)*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C xd(nd, jx) = tempd(nd) +C ENDDO +C x(jx) = temp +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=n,j+1,-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd( +C + nd, i) +C ENDDO +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C xd(nd, j) = tempd(nd) +C ENDDO +C x(j) = temp +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = kx +C DO i=n,j+1,-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)*xd( +C + nd, ix) +C ENDDO +C temp = temp - a(i, j)*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C xd(nd, jx) = tempd(nd) +C ENDDO +C x(jx) = temp +C jx = jx - incx +C ENDDO +C END IF +CC +C RETURN +CC +CC End of DTRSV +CC +C END IF +C END + + SUBROUTINE DTRSV_DV(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, + + INCX, NBDIRS) +! +! Vector forward-mode derivative of DTRSV, black-box/Giles-style. +! Self-contained -- does not call DTRSV_D. +! + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX, NBDIRS + DOUBLE PRECISION A(LDA,*), AD(NBDIRSMAX,LDA,*) + DOUBLE PRECISION X(*), XD(NBDIRSMAX,*) + + DOUBLE PRECISION S(N), T(N), W(N), AD_SLICE(LDA,LDA) + INTEGER ND, I, J, KX + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + +C S = solution, overwriting X in place (same for every direction) + CALL DTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + DO I = 1, N + S(I) = X(KX + (I-1)*INCX) + END DO + + DO ND = 1, NBDIRS + + DO J = 1, N + DO I = 1, N + AD_SLICE(I,J) = AD(ND,I,J) + END DO + END DO + +C T = op(Ad)*S (local copy, S stays untouched) + DO I = 1, N + T(I) = S(I) + END DO + CALL DTRMV(UPLO, TRANS, DIAG, N, AD_SLICE, LDA, T, 1) + +C RHS = Xd_in - T, gathered respecting INCX + DO I = 1, N + W(I) = XD(ND, KX + (I-1)*INCX) - T(I) + END DO + + CALL DTRSV(UPLO, TRANS, DIAG, N, A, LDA, W, 1) + + DO I = 1, N + XD(ND, KX + (I-1)*INCX) = W(I) + END DO + + END DO + + RETURN + END SUBROUTINE DTRSV_DV + diff --git a/BLAS/src/strsm_b.f b/BLAS/src/strsm_b.f new file mode 100644 index 0000000..76115ef --- /dev/null +++ b/BLAS/src/strsm_b.f @@ -0,0 +1,903 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of strsm in reverse (adjoint) mode: +C gradient of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:out a:out b:in-out +C> \brief \b STRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C REAL ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C REAL A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> STRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**T. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is REAL +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is REAL array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is REAL array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE STRSM_B(side, uplo, transa, diag, m, n, alpha, alphab, +C + a, ab, lda, b, bb, ldb) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C REAL alpha +C REAL alphab +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C REAL a(lda, *), b(ldb, *) +C REAL ab(lda, *), bb(ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +CC .. +CC .. Local Scalars .. +C REAL temp +C REAL tempb +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, nounit, upper +C INTEGER ISIZE2OFA +CC .. +CC .. Parameters .. +C REAL zero +C PARAMETER (zero=0.0e+0) +C INTEGER max1 +C INTEGER max2 +C REAL tempb0 +C REAL tmp +C REAL tmpb +C REAL tmp0 +C REAL tmpb0 +C REAL tmp1 +C REAL tmpb1 +C REAL tmp2 +C REAL tmpb2 +C REAL tmp3 +C REAL tmpb3 +C REAL tmp4 +C REAL tmpb4 +C INTEGER ad_to +C INTEGER*4 branch +C INTEGER ad_from +C INTEGER ad_to0 +C INTEGER ad_from0 +C INTEGER ad_to1 +C INTEGER ad_from1 +C INTEGER ad_to2 +C INTEGER ad_from2 +C INTEGER ii2 +C INTEGER ii1 +CC .. +CC +CC Test the input parameters. +CC +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE IF (m .LT. 0) THEN +C CALL PUSHCONTROL3B(4) +C info = 5 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(6) +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) THEN +C CALL PUSHCONTROL3B(7) +C info = 11 +C ELSE +C CALL PUSHCONTROL3B(7) +C END IF +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (m .EQ. 0 .OR. n .EQ. 0) THEN +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=n,1,-1 +C DO i=m,1,-1 +C bb(i, j) = 0.0 +C ENDDO +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ELSE IF (lside) THEN +CC +CC Start the operations. +CC +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL4(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,k-1 +C tmp = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C ENDDO +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=1,m,1 +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C CALL POPREAL4(b(i, j)) +C tmpb = bb(i, j) +C bb(i, j) = tmpb +C bb(k, j) = bb(k, j) - a(i, k)*tmpb +C ab(i, k) = ab(i, k) - b(k, j)*tmpb +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPREAL4(b(k, j)) +C tempb0 = bb(k, j)/a(k, k) +C bb(k, j) = tempb0 +C ab(k, k) = ab(k, k) - b(k, j)*tempb0/a(k, k) +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C alphab = alphab + b(i, j)*bb(i, j) +C bb(i, j) = alpha*bb(i, j) +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C CALL PUSHREAL4(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from = k + 1 +C DO i=ad_from,m +C tmp0 = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp0 +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=m,1,-1 +C CALL POPINTEGER4(ad_from) +C DO i=m,ad_from,-1 +C CALL POPREAL4(b(i, j)) +C tmpb0 = bb(i, j) +C bb(i, j) = tmpb0 +C bb(k, j) = bb(k, j) - a(i, k)*tmpb0 +C ab(i, k) = ab(i, k) - b(k, j)*tmpb0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPREAL4(b(k, j)) +C tempb0 = bb(k, j)/a(k, k) +C bb(k, j) = tempb0 +C ab(k, k) = ab(k, k) - b(k, j)*tempb0/a(k, k) +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C alphab = alphab + b(i, j)*bb(i, j) +C bb(i, j) = alpha*bb(i, j) +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B. +CC +C DO j=1,n +C DO i=1,m +C temp = alpha*b(i, j) +C DO k=1,i-1 +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C tempb = bb(i, j) +C bb(i, j) = 0.0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C tempb0 = tempb/a(i, i) +C tempb = tempb0 +C ab(i, i) = ab(i, i) - temp*tempb0/a(i, i) +C END IF +C CALL POPINTEGER4(ad_to0) +C DO k=ad_to0,1,-1 +C ab(k, i) = ab(k, i) - b(k, j)*tempb +C bb(k, j) = bb(k, j) - a(k, i)*tempb +C ENDDO +C alphab = alphab + b(i, j)*tempb +C bb(i, j) = bb(i, j) + alpha*tempb +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C temp = alpha*b(i, j) +C ad_from0 = i + 1 +C DO k=ad_from0,m +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=1,m,1 +C CALL POPREAL4(b(i, j)) +C tempb = bb(i, j) +C bb(i, j) = 0.0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C tempb0 = tempb/a(i, i) +C tempb = tempb0 +C ab(i, i) = ab(i, i) - temp*tempb0/a(i, i) +C END IF +C CALL POPINTEGER4(ad_from0) +C DO k=m,ad_from0,-1 +C ab(k, i) = ab(k, i) - b(k, j)*tempb +C bb(k, j) = bb(k, j) - a(k, i)*tempb +C ENDDO +C alphab = alphab + b(i, j)*tempb +C bb(i, j) = bb(i, j) + alpha*tempb +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C tmp1 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp1 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C tempb0 = bb(i, j)/a(j, j) +C bb(i, j) = tempb0 +C ab(j, j) = ab(j, j) - b(i, j)*tempb0/a(j, j) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO k=ad_to1,1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C tmpb1 = bb(i, j) +C bb(i, j) = tmpb1 +C ab(k, j) = ab(k, j) - b(i, k)*tmpb1 +C bb(i, k) = bb(i, k) - a(k, j)*tmpb1 +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C alphab = alphab + b(i, j)*bb(i, j) +C bb(i, j) = alpha*bb(i, j) +C ENDDO +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C ad_from1 = j + 1 +C DO k=ad_from1,n +C DO i=1,m +C tmp2 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp2 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C tempb0 = bb(i, j)/a(j, j) +C bb(i, j) = tempb0 +C ab(j, j) = ab(j, j) - b(i, j)*tempb0/a(j, j) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from1) +C DO k=n,ad_from1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C tmpb2 = bb(i, j) +C bb(i, j) = tmpb2 +C ab(k, j) = ab(k, j) - b(i, k)*tmpb2 +C bb(i, k) = bb(i, k) - a(k, j)*tmpb2 +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C alphab = alphab + b(i, j)*bb(i, j) +C bb(i, j) = alpha*bb(i, j) +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL4(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO j=1,k-1 +C DO i=1,m +C tmp3 = b(i, j) - a(j, k)*b(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp3 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(j - 1) +C DO i=1,m +C CALL PUSHREAL4(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO k=1,n,1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, k)) +C alphab = alphab + b(i, k)*bb(i, k) +C bb(i, k) = alpha*bb(i, k) +C ENDDO +C CALL POPINTEGER4(ad_to2) +C DO j=ad_to2,1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C tmpb3 = bb(i, j) +C bb(i, j) = tmpb3 +C ab(j, k) = ab(j, k) - b(i, k)*tmpb3 +C bb(i, k) = bb(i, k) - a(j, k)*tmpb3 +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL4(b(i, k)) +C tempb0 = bb(i, k)/a(k, k) +C bb(i, k) = tempb0 +C ab(k, k) = ab(k, k) - b(i, k)*tempb0/a(k, k) +C ENDDO +C END IF +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL4(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from2 = k + 1 +C DO j=ad_from2,n +C DO i=1,m +C tmp4 = b(i, j) - a(j, k)*b(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp4 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C DO i=1,m +C CALL PUSHREAL4(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C alphab = 0.0 +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO k=n,1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, k)) +C alphab = alphab + b(i, k)*bb(i, k) +C bb(i, k) = alpha*bb(i, k) +C ENDDO +C CALL POPINTEGER4(ad_from2) +C DO j=n,ad_from2,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C tmpb4 = bb(i, j) +C bb(i, j) = tmpb4 +C ab(j, k) = ab(j, k) - b(i, k)*tmpb4 +C bb(i, k) = bb(i, k) - a(j, k)*tmpb4 +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL4(b(i, k)) +C tempb0 = bb(i, k)/a(k, k) +C bb(i, k) = tempb0 +C ab(k, k) = ab(k, k) - b(i, k)*tempb0/a(k, k) +C ENDDO +C END IF +C ENDDO +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE STRSM_B(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB) +! +! Reverse-mode (adjoint) derivative of STRSM via the Giles/black-box +! method. Uses only the original STRSM. +! +! CONVENTION: +! B : untouched, original forward-call input. +! BB : IN = seed adjoint dF/dX; OUT = adjoint dF/dB (in place). +! ALPHAB, AB : OUTPUT ONLY -- zeroed and filled here. +! + IMPLICIT NONE + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + REAL ALPHA, ALPHAB + REAL A(LDA,*), AB(LDA,*) + REAL B(LDB,*), BB(LDB,*) + + REAL X(M,N) + CHARACTER TRANSA_T + LOGICAL LEFT, UPPER, UNIT, NOTRANS + INTEGER I, J, K + + LEFT = (SIDE.EQ.'L' .OR. SIDE.EQ.'l') + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + NOTRANS = (TRANSA.EQ.'N' .OR. TRANSA.EQ.'n') + IF (NOTRANS) THEN + TRANSA_T = 'T' + ELSE + TRANSA_T = 'N' + END IF + + IF (M.EQ.0 .OR. N.EQ.0) THEN + ALPHAB = 0.0E0 + RETURN + END IF + +C Step 1: Yb solves op(A)^T*Yb = Xb (SIDE='L') or Yb*op(A)^T = Xb (SIDE='R') + CALL STRSM(SIDE, UPLO, TRANSA_T, DIAG, M, N, 1.0E0, A, LDA, BB, LDB) + +C Step 2: recompute X from the ORIGINAL, untouched B + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + +C Step 3: alphab = (ORIGINAL B, not X) + ALPHAB = 0.0E0 + DO J = 1, N + DO I = 1, M + ALPHAB = ALPHAB + BB(I,J)*B(I,J) + END DO + END DO + +C Step 4: Ab, restricted to the triangle STRSM actually reads + DO J = 1, LDA + DO I = 1, LDA + AB(I,J) = 0.0E0 + END DO + END DO + + IF (LEFT) THEN + DO J = 1, M + DO I = 1, M + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + DO K = 1, N + AB(I,J) = AB(I,J) - BB(I,K)*X(J,K) + END DO + ELSE + DO K = 1, N + AB(I,J) = AB(I,J) - X(I,K)*BB(J,K) + END DO + END IF + END IF + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + DO K = 1, M + AB(I,J) = AB(I,J) - X(K,I)*BB(K,J) + END DO + ELSE + DO K = 1, M + AB(I,J) = AB(I,J) - BB(K,I)*X(K,J) + END DO + END IF + END IF + END IF + END DO + END DO + END IF + +C Step 5: Bb = alpha * Yb (BB currently holds Yb from Step 1) + DO J = 1, N + DO I = 1, M + BB(I,J) = ALPHA*BB(I,J) + END DO + END DO + + RETURN + END SUBROUTINE STRSM_B + diff --git a/BLAS/src/strsm_bv.f b/BLAS/src/strsm_bv.f new file mode 100644 index 0000000..da12372 --- /dev/null +++ b/BLAS/src/strsm_bv.f @@ -0,0 +1,1047 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of strsm in reverse (adjoint) mode (with options multiDirectional): +C gradient of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:out a:out b:in-out +C> \brief \b STRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C REAL ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C REAL A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> STRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**T. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is REAL +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is REAL array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is REAL array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE STRSM_BV(side, uplo, transa, diag, m, n, alpha, alphab +C + , a, ab, lda, b, bb, ldb, nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C REAL alpha +C REAL alphab(nbdirsmax) +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C REAL a(lda, *), b(ldb, *) +C REAL ab(nbdirsmax, lda, *), bb(nbdirsmax, ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +CC .. +CC .. Local Scalars .. +C REAL temp +C REAL tempb(nbdirsmax) +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, nounit, upper +C INTEGER ISIZE2OFA +CC .. +CC .. Parameters .. +C REAL zero +C PARAMETER (zero=0.0e+0) +C INTEGER max1 +C INTEGER max2 +C INTEGER nd +C REAL tempb0(nbdirsmax) +C REAL tmp +C REAL tmpb(nbdirsmax) +C REAL tmp0 +C REAL tmpb0(nbdirsmax) +C REAL tmp1 +C REAL tmpb1(nbdirsmax) +C REAL tmp2 +C REAL tmpb2(nbdirsmax) +C REAL tmp3 +C REAL tmpb3(nbdirsmax) +C REAL tmp4 +C REAL tmpb4(nbdirsmax) +C INTEGER ad_to +C INTEGER*4 branch +C INTEGER ad_from +C INTEGER ad_to0 +C INTEGER ad_from0 +C INTEGER ad_to1 +C INTEGER ad_from1 +C INTEGER ad_to2 +C INTEGER ad_from2 +C INTEGER ii2 +C INTEGER ii1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE IF (m .LT. 0) THEN +C CALL PUSHCONTROL3B(4) +C info = 5 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(6) +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) THEN +C CALL PUSHCONTROL3B(7) +C info = 11 +C ELSE +C CALL PUSHCONTROL3B(7) +C END IF +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (m .EQ. 0 .OR. n .EQ. 0) THEN +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=n,1,-1 +C DO i=m,1,-1 +C DO nd=1,nbdirs +C bb(nd, i, j) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C ELSE IF (lside) THEN +CC +CC Start the operations. +CC +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL4(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,k-1 +C tmp = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=1,m,1 +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tmpb(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb(nd) +C bb(nd, k, j) = bb(nd, k, j) - a(i, k)*tmpb(nd) +C ab(nd, i, k) = ab(nd, i, k) - b(k, j)*tmpb(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPREAL4(b(k, j)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, k, j)/a(k, k) +C bb(nd, k, j) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) - b(k, j)*tempb0(nd)/a +C + (k, k) +C ENDDO +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*bb(nd, i, j) +C bb(nd, i, j) = alpha*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C CALL PUSHREAL4(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from = k + 1 +C DO i=ad_from,m +C tmp0 = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp0 +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=m,1,-1 +C CALL POPINTEGER4(ad_from) +C DO i=m,ad_from,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tmpb0(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb0(nd) +C bb(nd, k, j) = bb(nd, k, j) - a(i, k)*tmpb0(nd) +C ab(nd, i, k) = ab(nd, i, k) - b(k, j)*tmpb0(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPREAL4(b(k, j)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, k, j)/a(k, k) +C bb(nd, k, j) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) - b(k, j)*tempb0(nd)/a +C + (k, k) +C ENDDO +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*bb(nd, i, j) +C bb(nd, i, j) = alpha*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B. +CC +C DO j=1,n +C DO i=1,m +C temp = alpha*b(i, j) +C DO k=1,i-1 +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tempb(nd) = bb(nd, i, j) +C bb(nd, i, j) = 0.0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, i, i) = ab(nd, i, i) - temp*tempb0(nd)/a(i, i +C + ) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to0) +C DO k=ad_to0,1,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) - b(k, j)*tempb(nd) +C bb(nd, k, j) = bb(nd, k, j) - a(k, i)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*tempb(nd) +C bb(nd, i, j) = bb(nd, i, j) + alpha*tempb(nd) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C temp = alpha*b(i, j) +C ad_from0 = i + 1 +C DO k=ad_from0,m +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=1,m,1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tempb(nd) = bb(nd, i, j) +C bb(nd, i, j) = 0.0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, i, i) = ab(nd, i, i) - temp*tempb0(nd)/a(i, i +C + ) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from0) +C DO k=m,ad_from0,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) - b(k, j)*tempb(nd) +C bb(nd, k, j) = bb(nd, k, j) - a(k, i)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*tempb(nd) +C bb(nd, i, j) = bb(nd, i, j) + alpha*tempb(nd) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C tmp1 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp1 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, i, j)/a(j, j) +C bb(nd, i, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - b(i, j)*tempb0(nd)/a(j +C + , j) +C ENDDO +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO k=ad_to1,1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tmpb1(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb1(nd) +C ab(nd, k, j) = ab(nd, k, j) - b(i, k)*tmpb1(nd) +C bb(nd, i, k) = bb(nd, i, k) - a(k, j)*tmpb1(nd) +C ENDDO +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*bb(nd, i, j) +C bb(nd, i, j) = alpha*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C ad_from1 = j + 1 +C DO k=ad_from1,n +C DO i=1,m +C tmp2 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp2 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, i, j)/a(j, j) +C bb(nd, i, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - b(i, j)*tempb0(nd)/a(j +C + , j) +C ENDDO +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from1) +C DO k=n,ad_from1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tmpb2(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb2(nd) +C ab(nd, k, j) = ab(nd, k, j) - b(i, k)*tmpb2(nd) +C bb(nd, i, k) = bb(nd, i, k) - a(k, j)*tmpb2(nd) +C ENDDO +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, j)*bb(nd, i, j) +C bb(nd, i, j) = alpha*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL4(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO j=1,k-1 +C DO i=1,m +C tmp3 = b(i, j) - a(j, k)*b(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp3 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(j - 1) +C DO i=1,m +C CALL PUSHREAL4(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO k=1,n,1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, k)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, k)*bb(nd, i, k) +C bb(nd, i, k) = alpha*bb(nd, i, k) +C ENDDO +C ENDDO +C CALL POPINTEGER4(ad_to2) +C DO j=ad_to2,1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tmpb3(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb3(nd) +C ab(nd, j, k) = ab(nd, j, k) - b(i, k)*tmpb3(nd) +C bb(nd, i, k) = bb(nd, i, k) - a(j, k)*tmpb3(nd) +C ENDDO +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL4(b(i, k)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, i, k)/a(k, k) +C bb(nd, i, k) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) - b(i, k)*tempb0(nd)/a(k, +C + k) +C ENDDO +C ENDDO +C END IF +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHREAL4(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from2 = k + 1 +C DO j=ad_from2,n +C DO i=1,m +C tmp4 = b(i, j) - a(j, k)*b(i, k) +C CALL PUSHREAL4(b(i, j)) +C b(i, j) = tmp4 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C DO i=1,m +C CALL PUSHREAL4(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = 0.0 +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO k=n,1,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, k)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + b(i, k)*bb(nd, i, k) +C bb(nd, i, k) = alpha*bb(nd, i, k) +C ENDDO +C ENDDO +C CALL POPINTEGER4(ad_from2) +C DO j=n,ad_from2,-1 +C DO i=m,1,-1 +C CALL POPREAL4(b(i, j)) +C DO nd=1,nbdirs +C tmpb4(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb4(nd) +C ab(nd, j, k) = ab(nd, j, k) - b(i, k)*tmpb4(nd) +C bb(nd, i, k) = bb(nd, i, k) - a(j, k)*tmpb4(nd) +C ENDDO +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C DO i=m,1,-1 +C CALL POPREAL4(b(i, k)) +C DO nd=1,nbdirs +C tempb0(nd) = bb(nd, i, k)/a(k, k) +C bb(nd, i, k) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) - b(i, k)*tempb0(nd)/a(k, +C + k) +C ENDDO +C ENDDO +C END IF +C ENDDO +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE STRSM_BV(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB, NBDIRS) +! +! Vector reverse-mode (adjoint) derivative of STRSM, black-box/Giles-style. +! Self-contained -- does not call STRSM_B. +! + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB, NBDIRS + REAL ALPHA + REAL ALPHAB(NBDIRSMAX) + REAL A(LDA,*), AB(NBDIRSMAX,LDA,*) + REAL B(LDB,*), BB(NBDIRSMAX,LDB,*) + + REAL X(M,N) + REAL BB_SLICE(LDB,N), AB_SLICE(LDA,LDA) + CHARACTER TRANSA_T + LOGICAL LEFT, UPPER, UNIT, NOTRANS + INTEGER ND, I, J, K + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + LEFT = (SIDE.EQ.'L' .OR. SIDE.EQ.'l') + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + NOTRANS = (TRANSA.EQ.'N' .OR. TRANSA.EQ.'n') + IF (NOTRANS) THEN + TRANSA_T = 'T' + ELSE + TRANSA_T = 'N' + END IF + + IF (M.EQ.0 .OR. N.EQ.0) THEN + DO ND = 1, NBDIRS + ALPHAB(ND) = 0.0E0 + END DO + RETURN + END IF + +C X = solution of the original forward call (same for every direction) + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO ND = 1, NBDIRS + +C Gather this direction's seed out of the interleaved BB layout + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = BB(ND,I,J) + END DO + END DO + +C Step 1: Yb solves op(A)^T*Yb = Xb (overwrites BB_SLICE in place) + CALL STRSM(SIDE, UPLO, TRANSA_T, DIAG, M, N, 1.0E0, + + A, LDA, BB_SLICE, LDB) + +C Step 2: alphab(nd) = (ORIGINAL B, not X) + ALPHAB(ND) = 0.0E0 + DO J = 1, N + DO I = 1, M + ALPHAB(ND) = ALPHAB(ND) + BB_SLICE(I,J)*B(I,J) + END DO + END DO + +C Step 3: Ab for this direction, restricted to the triangle read + DO J = 1, LDA + DO I = 1, LDA + AB_SLICE(I,J) = 0.0E0 + END DO + END DO + + IF (LEFT) THEN + DO J = 1, M + DO I = 1, M + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - BB_SLICE(I,K)*X(J,K) + END DO + ELSE + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - X(I,K)*BB_SLICE(J,K) + END DO + END IF + END IF + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - X(K,I)*BB_SLICE(K,J) + END DO + ELSE + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - BB_SLICE(K,I)*X(K,J) + END DO + END IF + END IF + END IF + END DO + END DO + END IF + +C Step 4: Bb = alpha * Yb (BB_SLICE currently holds Yb) + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = ALPHA*BB_SLICE(I,J) + END DO + END DO + +C Scatter this direction's results back into the interleaved layout + DO J = 1, LDA + DO I = 1, LDA + AB(ND,I,J) = AB_SLICE(I,J) + END DO + END DO + DO J = 1, N + DO I = 1, M + BB(ND,I,J) = BB_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE STRSM_BV + diff --git a/BLAS/src/strsm_d.f b/BLAS/src/strsm_d.f new file mode 100644 index 0000000..06800f4 --- /dev/null +++ b/BLAS/src/strsm_d.f @@ -0,0 +1,529 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of strsm in forward (tangent) mode: +C variations of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:in a:in b:in-out +C> \brief \b STRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C REAL ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C REAL A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> STRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**T. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is REAL +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is REAL array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is REAL array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE STRSM_D(side, uplo, transa, diag, m, n, alpha, alphad, +C + a, ad, lda, b, bd, ldb) +C IMPLICIT NONE +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C REAL alpha +C REAL alphad +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C REAL a(lda, *), b(ldb, *) +C REAL ad(lda, *), bd(ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +CC .. +CC .. Local Scalars .. +C REAL temp +C REAL tempd +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, nounit, upper +CC .. +CC .. Parameters .. +C REAL zero +C PARAMETER (zero=0.0e+0) +C INTEGER max1 +C INTEGER max2 +C REAL temp0 +CC .. +CC +CC Test the input parameters. +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 4 +C ELSE IF (m .LT. 0) THEN +C info = 5 +C ELSE IF (n .LT. 0) THEN +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) info = 11 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('STRSM ', info) +C RETURN +C ELSE IF (m .EQ. 0 .OR. n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=1,n +C DO i=1,m +C bd(i, j) = 0.0 +C b(i, j) = zero +C ENDDO +C ENDDO +C RETURN +C ELSE +CC +CC Start the operations. +CC +C IF (lside) THEN +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C bd(k, j) = (bd(k, j)-temp0*ad(k, k))/a(k, k) +C b(k, j) = temp0 +C END IF +C DO i=1,k-1 +C bd(i, j) = bd(i, j) - a(i, k)*bd(k, j) - b(k, j)*ad( +C + i, k) +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C bd(k, j) = (bd(k, j)-temp0*ad(k, k))/a(k, k) +C b(k, j) = temp0 +C END IF +C DO i=k+1,m +C bd(i, j) = bd(i, j) - a(i, k)*bd(k, j) - b(k, j)*ad( +C + i, k) +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B. +CC +C DO j=1,n +C DO i=1,m +C tempd = b(i, j)*alphad + alpha*bd(i, j) +C temp = alpha*b(i, j) +C DO k=1,i-1 +C tempd = tempd - b(k, j)*ad(k, i) - a(k, i)*bd(k, j) +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C tempd = (tempd-temp0*ad(i, i))/a(i, i) +C temp = temp0 +C END IF +C bd(i, j) = tempd +C b(i, j) = temp +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C tempd = b(i, j)*alphad + alpha*bd(i, j) +C temp = alpha*b(i, j) +C DO k=i+1,m +C tempd = tempd - b(k, j)*ad(k, i) - a(k, i)*bd(k, j) +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C tempd = (tempd-temp0*ad(i, i))/a(i, i) +C temp = temp0 +C END IF +C bd(i, j) = tempd +C b(i, j) = temp +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(k, j) - a(k, j)*bd(i +C + , k) +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C bd(i, j) = (bd(i, j)-temp0*ad(j, j))/a(j, j) +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=j+1,n +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(k, j) - a(k, j)*bd(i +C + , k) +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C bd(i, j) = (bd(i, j)-temp0*ad(j, j))/a(j, j) +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C bd(i, k) = (bd(i, k)-temp0*ad(k, k))/a(k, k) +C b(i, k) = temp0 +C ENDDO +C END IF +C DO j=1,k-1 +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(j, k) - a(j, k)*bd(i, k +C + ) +C b(i, j) = b(i, j) - a(j, k)*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C bd(i, k) = b(i, k)*alphad + alpha*bd(i, k) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C bd(i, k) = (bd(i, k)-temp0*ad(k, k))/a(k, k) +C b(i, k) = temp0 +C ENDDO +C END IF +C DO j=k+1,n +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(j, k) - a(j, k)*bd(i, k +C + ) +C b(i, j) = b(i, j) - a(j, k)*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C bd(i, k) = b(i, k)*alphad + alpha*bd(i, k) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C END IF +CC +C RETURN +CC +CC End of STRSM +CC +C END IF +C END + + SUBROUTINE STRSM_D(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB) +! +! Forward-mode derivative of STRSM via the black-box / Giles-style +! approach: differentiate op(A)*X = alpha*B directly. Uses only the +! original STRSM and STRMM. +! + IMPLICIT NONE + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + REAL ALPHA, ALPHAD + REAL A(LDA,*), AD(LDA,*) + REAL B(LDB,*), BD(LDB,*) + + REAL X(M,N), T(M,N) + INTEGER I, J + + IF (M.EQ.0 .OR. N.EQ.0) RETURN + +C Step 1: X = solution of the original forward call + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + +C Step 2: T = op(Ad)*X (SIDE='L') or X*op(Ad) (SIDE='R') + DO J = 1, N + DO I = 1, M + T(I,J) = X(I,J) + END DO + END DO + CALL STRMM(SIDE, UPLO, TRANSA, DIAG, M, N, 1.0E0, AD, LDA, T, M) + +C Step 3: RHS = alphad*B + alpha*Bd - T, built in place in BD + DO J = 1, N + DO I = 1, M + BD(I,J) = ALPHAD*B(I,J) + ALPHA*BD(I,J) - T(I,J) + END DO + END DO + +C Step 4: solve the SAME triangular system again -> dX, overwrites BD + CALL STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, 1.0E0, A, LDA, BD, LDB) + + RETURN + END SUBROUTINE STRSM_D + diff --git a/BLAS/src/strsm_dv.f b/BLAS/src/strsm_dv.f new file mode 100644 index 0000000..8fa8c02 --- /dev/null +++ b/BLAS/src/strsm_dv.f @@ -0,0 +1,636 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of strsm in forward (tangent) mode (with options multiDirectional): +C variations of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:in a:in b:in-out +C> \brief \b STRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C REAL ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C REAL A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> STRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**T. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is REAL +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is REAL array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is REAL array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE STRSM_DV(side, uplo, transa, diag, m, n, alpha, alphad +C + , a, ad, lda, b, bd, ldb, nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C REAL alpha +C REAL alphad(nbdirsmax) +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C REAL a(lda, *), b(ldb, *) +C REAL ad(nbdirsmax, lda, *), bd(nbdirsmax, ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +CC .. +CC .. Local Scalars .. +C REAL temp +C REAL tempd(nbdirsmax) +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, nounit, upper +CC .. +CC .. Parameters .. +C REAL zero +C PARAMETER (zero=0.0e+0) +C INTEGER max1 +C INTEGER max2 +C INTEGER nd +C REAL temp0 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 4 +C ELSE IF (m .LT. 0) THEN +C info = 5 +C ELSE IF (n .LT. 0) THEN +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) info = 11 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('STRSM ', info) +C RETURN +C ELSE IF (m .EQ. 0 .OR. n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = 0.0 +C ENDDO +C b(i, j) = zero +C ENDDO +C ENDDO +C RETURN +C ELSE +CC +CC Start the operations. +CC +C IF (lside) THEN +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, +C + j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, k, j) = (bd(nd, k, j)-temp0*ad(nd, k, k))/a +C + (k, k) +C ENDDO +C b(k, j) = temp0 +C END IF +C DO i=1,k-1 +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - a(i, k)*bd(nd, k, j) +C + - b(k, j)*ad(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, +C + j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, k, j) = (bd(nd, k, j)-temp0*ad(nd, k, k))/a +C + (k, k) +C ENDDO +C b(k, j) = temp0 +C END IF +C DO i=k+1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - a(i, k)*bd(nd, k, j) +C + - b(k, j)*ad(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B. +CC +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C tempd(nd) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C temp = alpha*b(i, j) +C DO k=1,i-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*ad(nd, k, i) - a(k, +C + i)*bd(nd, k, j) +C ENDDO +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, i, i))/a(i, i) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C bd(nd, i, j) = tempd(nd) +C ENDDO +C b(i, j) = temp +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C temp = alpha*b(i, j) +C DO k=i+1,m +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*ad(nd, k, i) - a(k, +C + i)*bd(nd, k, j) +C ENDDO +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, i, i))/a(i, i) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C bd(nd, i, j) = tempd(nd) +C ENDDO +C b(i, j) = temp +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, k, j) - +C + a(k, j)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C DO nd=1,nbdirs +C bd(nd, i, j) = (bd(nd, i, j)-temp0*ad(nd, j, j))/a(j +C + , j) +C ENDDO +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=j+1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, k, j) - +C + a(k, j)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C DO nd=1,nbdirs +C bd(nd, i, j) = (bd(nd, i, j)-temp0*ad(nd, j, j))/a(j +C + , j) +C ENDDO +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*ad(nd, k, k))/a(k, +C + k) +C ENDDO +C b(i, k) = temp0 +C ENDDO +C END IF +C DO j=1,k-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, j, k) - a +C + (j, k)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(j, k)*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, k) = b(i, k)*alphad(nd) + alpha*bd(nd, i, k) +C ENDDO +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*ad(nd, k, k))/a(k, +C + k) +C ENDDO +C b(i, k) = temp0 +C ENDDO +C END IF +C DO j=k+1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, j, k) - a +C + (j, k)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(j, k)*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, k) = b(i, k)*alphad(nd) + alpha*bd(nd, i, k) +C ENDDO +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C END IF +CC +C RETURN +CC +CC End of STRSM +CC +C END IF +C END + + SUBROUTINE STRSM_DV(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB, NBDIRS) +! +! Vector forward-mode derivative of STRSM (black-box/Giles-style). +! Self-contained -- does not call STRSM_D. AD/BD store direction as +! the FASTEST-varying index (nbdirsmax, LDA/LDB, *): gather each +! direction into a plain work array before use, scatter back after. +! + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB, NBDIRS + REAL ALPHA + REAL ALPHAD(NBDIRSMAX) + REAL A(LDA,*), AD(NBDIRSMAX,LDA,*) + REAL B(LDB,*), BD(NBDIRSMAX,LDB,*) + + REAL X(M,N), T(M,N) + REAL AD_SLICE(LDA,N), BD_SLICE(LDB,N) + INTEGER ND, I, J + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (M.EQ.0 .OR. N.EQ.0) RETURN + +C X = solution of the original forward call (same for every direction) + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO ND = 1, NBDIRS + +C Gather this direction out of the interleaved AD/BD layout + DO J = 1, N + DO I = 1, M + AD_SLICE(I,J) = AD(ND,I,J) + BD_SLICE(I,J) = BD(ND,I,J) + END DO + END DO + +C T = op(Ad)*X (SIDE='L') or X*op(Ad) (SIDE='R') + DO J = 1, N + DO I = 1, M + T(I,J) = X(I,J) + END DO + END DO + CALL STRMM(SIDE, UPLO, TRANSA, DIAG, M, N, 1.0E0, + + AD_SLICE, LDA, T, M) + +C RHS = alphad*B + alpha*Bd - T, built in place in BD_SLICE + DO J = 1, N + DO I = 1, M + BD_SLICE(I,J) = ALPHAD(ND)*B(I,J) + ALPHA*BD_SLICE(I,J) + + - T(I,J) + END DO + END DO + +C Solve the same triangular system again -> dX for this direction + CALL STRSM(SIDE, UPLO, TRANSA, DIAG, M, N, 1.0E0, + + A, LDA, BD_SLICE, LDB) + +C Scatter the result back into the interleaved layout + DO J = 1, N + DO I = 1, M + BD(ND,I,J) = BD_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE STRSM_DV + diff --git a/BLAS/src/strsv_b.f b/BLAS/src/strsv_b.f new file mode 100644 index 0000000..862763c --- /dev/null +++ b/BLAS/src/strsv_b.f @@ -0,0 +1,651 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of strsv in reverse (adjoint) mode: +C gradient of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:out +C> \brief \b STRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C REAL A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> STRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**T*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is REAL array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is REAL array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== + SUBROUTINE STRSV_B(uplo, trans, diag, n, a, ab, lda, x, xb, incx) + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' +C Hint: ISIZE2OFa should be the size of dimension 2 of array a +C +C -- Reference BLAS level2 routine -- +C -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +C +C .. Scalar Arguments .. + INTEGER incx, lda, n + CHARACTER diag, trans, uplo +C .. +C .. Array Arguments .. + REAL a(lda, *), x(*) + REAL ab(lda, *), xb(*) +C .. +C +C ===================================================================== +C .. +C .. Local Scalars .. + REAL temp + REAL tempb + INTEGER i, info, ix, j, jx, kx + LOGICAL nounit + EXTERNAL LSAME + INTEGER ISIZE2OFA +C .. +C .. External Functions .. + INTEGER get_ISIZE2OFA + EXTERNAL get_ISIZE2OFA + LOGICAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, check_ISIZE2OFA_initialized +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX + INTEGER max1 + REAL tempb0 + INTEGER ad_from + INTEGER*4 branch + INTEGER ad_from0 + INTEGER ad_from1 + INTEGER ad_from2 + INTEGER ad_to + INTEGER ad_to0 + INTEGER ad_to1 + INTEGER ad_to2 + INTEGER ii2 + INTEGER ii1 +C .. +C +C Test the input parameters. +C + CALL check_ISIZE2OFA_initialized() + ISIZE2OFA = get_ISIZE2OFA() + info = 0 + IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN + CALL PUSHCONTROL3B(0) + info = 1 + ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) + + .AND. (.NOT.LSAME(trans, 'C'))) THEN + CALL PUSHCONTROL3B(1) + info = 2 + ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN + CALL PUSHCONTROL3B(2) + info = 3 + ELSE IF (n .LT. 0) THEN + CALL PUSHCONTROL3B(3) + info = 4 + ELSE + IF (1 .LT. n) THEN + max1 = n + ELSE + max1 = 1 + END IF + IF (lda .LT. max1) THEN + CALL PUSHCONTROL3B(4) + info = 6 + ELSE IF (incx .EQ. 0) THEN + CALL PUSHCONTROL3B(5) + info = 8 + ELSE + CALL PUSHCONTROL3B(5) + END IF + END IF + IF (info .EQ. 0) THEN +C +C Quick return if possible. +C + IF (n .EQ. 0) THEN + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + ELSE +C + nounit = LSAME(diag, 'N') +C +C Set up the start point in X if the increment is not unity. This +C will be ( N - 1 )*INCX too small for descending loops. +C + IF (incx .LE. 0) THEN + CALL PUSHCONTROL1B(0) + kx = 1 - (n-1)*incx + ELSE IF (incx .NE. 1) THEN + CALL PUSHCONTROL1B(1) + kx = 1 + ELSE + CALL PUSHCONTROL1B(1) + END IF +C +C Start the operations. In this version the elements of A are +C accessed sequentially with one pass through A. +C + IF (LSAME(trans, 'N')) THEN +C +C Form x := inv( A )*x. +C + IF (LSAME(uplo, 'U')) THEN + IF (incx .EQ. 1) THEN + DO j=n,1,-1 + IF (nounit) THEN + CALL PUSHREAL4(x(j)) + x(j) = x(j)/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(temp) + temp = x(j) + ad_from = j - 1 + DO i=ad_from,1,-1 + CALL PUSHREAL4(x(i)) + x(i) = x(i) - temp*a(i, j) + ENDDO + CALL PUSHINTEGER4(ad_from) + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + DO j=1,n,1 + tempb = 0.0 + CALL POPINTEGER4(ad_from) + DO i=1,ad_from,1 + CALL POPREAL4(x(i)) + tempb = tempb - a(i, j)*xb(i) + ab(i, j) = ab(i, j) - temp*xb(i) + ENDDO + CALL POPREAL4(temp) + xb(j) = xb(j) + tempb + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(x(j)) + tempb0 = xb(j)/a(j, j) + xb(j) = tempb0 + ab(j, j) = ab(j, j) - x(j)*tempb0/a(j, j) + END IF + ENDDO + ELSE + jx = kx + (n-1)*incx + DO j=n,1,-1 + IF (nounit) THEN + CALL PUSHREAL4(x(jx)) + x(jx) = x(jx)/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(temp) + temp = x(jx) + CALL PUSHINTEGER4(ix) + ix = jx + ad_from0 = j - 1 + DO i=ad_from0,1,-1 + CALL PUSHINTEGER4(ix) + ix = ix - incx + CALL PUSHREAL4(x(ix)) + x(ix) = x(ix) - temp*a(i, j) + ENDDO + CALL PUSHINTEGER4(ad_from0) + CALL PUSHINTEGER4(jx) + jx = jx - incx + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + DO j=1,n,1 + CALL POPINTEGER4(jx) + tempb = 0.0 + CALL POPINTEGER4(ad_from0) + DO i=1,ad_from0,1 + CALL POPREAL4(x(ix)) + tempb = tempb - a(i, j)*xb(ix) + ab(i, j) = ab(i, j) - temp*xb(ix) + CALL POPINTEGER4(ix) + ENDDO + CALL POPINTEGER4(ix) + CALL POPREAL4(temp) + xb(jx) = xb(jx) + tempb + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(x(jx)) + tempb0 = xb(jx)/a(j, j) + xb(jx) = tempb0 + ab(j, j) = ab(j, j) - x(jx)*tempb0/a(j, j) + END IF + ENDDO + END IF + ELSE IF (incx .EQ. 1) THEN + DO j=1,n + IF (nounit) THEN + CALL PUSHREAL4(x(j)) + x(j) = x(j)/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(temp) + temp = x(j) + ad_from1 = j + 1 + DO i=ad_from1,n + CALL PUSHREAL4(x(i)) + x(i) = x(i) - temp*a(i, j) + ENDDO + CALL PUSHINTEGER4(ad_from1) + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + DO j=n,1,-1 + tempb = 0.0 + CALL POPINTEGER4(ad_from1) + DO i=n,ad_from1,-1 + CALL POPREAL4(x(i)) + tempb = tempb - a(i, j)*xb(i) + ab(i, j) = ab(i, j) - temp*xb(i) + ENDDO + CALL POPREAL4(temp) + xb(j) = xb(j) + tempb + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(x(j)) + tempb0 = xb(j)/a(j, j) + xb(j) = tempb0 + ab(j, j) = ab(j, j) - x(j)*tempb0/a(j, j) + END IF + ENDDO + ELSE + jx = kx + DO j=1,n + IF (nounit) THEN + CALL PUSHREAL4(x(jx)) + x(jx) = x(jx)/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(temp) + temp = x(jx) + CALL PUSHINTEGER4(ix) + ix = jx + ad_from2 = j + 1 + DO i=ad_from2,n + CALL PUSHINTEGER4(ix) + ix = ix + incx + CALL PUSHREAL4(x(ix)) + x(ix) = x(ix) - temp*a(i, j) + ENDDO + CALL PUSHINTEGER4(ad_from2) + CALL PUSHINTEGER4(jx) + jx = jx + incx + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + DO j=n,1,-1 + CALL POPINTEGER4(jx) + tempb = 0.0 + CALL POPINTEGER4(ad_from2) + DO i=n,ad_from2,-1 + CALL POPREAL4(x(ix)) + tempb = tempb - a(i, j)*xb(ix) + ab(i, j) = ab(i, j) - temp*xb(ix) + CALL POPINTEGER4(ix) + ENDDO + CALL POPINTEGER4(ix) + CALL POPREAL4(temp) + xb(jx) = xb(jx) + tempb + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(x(jx)) + tempb0 = xb(jx)/a(j, j) + xb(jx) = tempb0 + ab(j, j) = ab(j, j) - x(jx)*tempb0/a(j, j) + END IF + ENDDO + END IF + ELSE IF (LSAME(uplo, 'U')) THEN +C +C Form x := inv( A**T )*x. +C + IF (incx .EQ. 1) THEN + DO j=1,n + temp = x(j) + DO i=1,j-1 + temp = temp - a(i, j)*x(i) + ENDDO + CALL PUSHINTEGER4(i - 1) + IF (nounit) THEN + CALL PUSHREAL4(temp) + temp = temp/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(x(j)) + x(j) = temp + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + DO j=n,1,-1 + CALL POPREAL4(x(j)) + tempb = xb(j) + xb(j) = 0.0 + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(temp) + tempb0 = tempb/a(j, j) + tempb = tempb0 + ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) + END IF + CALL POPINTEGER4(ad_to) + DO i=ad_to,1,-1 + ab(i, j) = ab(i, j) - x(i)*tempb + xb(i) = xb(i) - a(i, j)*tempb + ENDDO + xb(j) = xb(j) + tempb + ENDDO + ELSE + jx = kx + DO j=1,n + temp = x(jx) + ix = kx + DO i=1,j-1 + temp = temp - a(i, j)*x(ix) + CALL PUSHINTEGER4(ix) + ix = ix + incx + ENDDO + CALL PUSHINTEGER4(i - 1) + IF (nounit) THEN + CALL PUSHREAL4(temp) + temp = temp/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(x(jx)) + x(jx) = temp + CALL PUSHINTEGER4(jx) + jx = jx + incx + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + DO j=n,1,-1 + CALL POPINTEGER4(jx) + CALL POPREAL4(x(jx)) + tempb = xb(jx) + xb(jx) = 0.0 + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(temp) + tempb0 = tempb/a(j, j) + tempb = tempb0 + ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) + END IF + CALL POPINTEGER4(ad_to0) + DO i=ad_to0,1,-1 + CALL POPINTEGER4(ix) + ab(i, j) = ab(i, j) - x(ix)*tempb + xb(ix) = xb(ix) - a(i, j)*tempb + ENDDO + xb(jx) = xb(jx) + tempb + ENDDO + END IF + ELSE IF (incx .EQ. 1) THEN + DO j=n,1,-1 + temp = x(j) + DO i=n,j+1,-1 + temp = temp - a(i, j)*x(i) + ENDDO + CALL PUSHINTEGER4(i + 1) + IF (nounit) THEN + CALL PUSHREAL4(temp) + temp = temp/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(x(j)) + x(j) = temp + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + DO j=1,n,1 + CALL POPREAL4(x(j)) + tempb = xb(j) + xb(j) = 0.0 + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(temp) + tempb0 = tempb/a(j, j) + tempb = tempb0 + ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) + END IF + CALL POPINTEGER4(ad_to1) + DO i=ad_to1,n,1 + ab(i, j) = ab(i, j) - x(i)*tempb + xb(i) = xb(i) - a(i, j)*tempb + ENDDO + xb(j) = xb(j) + tempb + ENDDO + ELSE + kx = kx + (n-1)*incx + jx = kx + DO j=n,1,-1 + temp = x(jx) + ix = kx + DO i=n,j+1,-1 + temp = temp - a(i, j)*x(ix) + CALL PUSHINTEGER4(ix) + ix = ix - incx + ENDDO + CALL PUSHINTEGER4(i + 1) + IF (nounit) THEN + CALL PUSHREAL4(temp) + temp = temp/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(x(jx)) + x(jx) = temp + CALL PUSHINTEGER4(jx) + jx = jx - incx + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + ab(ii2, ii1) = 0.0 + ENDDO + ENDDO + DO j=1,n,1 + CALL POPINTEGER4(jx) + CALL POPREAL4(x(jx)) + tempb = xb(jx) + xb(jx) = 0.0 + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(temp) + tempb0 = tempb/a(j, j) + tempb = tempb0 + ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) + END IF + CALL POPINTEGER4(ad_to2) + DO i=ad_to2,n,1 + CALL POPINTEGER4(ix) + ab(i, j) = ab(i, j) - x(ix)*tempb + xb(ix) = xb(ix) - a(i, j)*tempb + ENDDO + xb(jx) = xb(jx) + tempb + ENDDO + END IF + CALL POPCONTROL1B(branch) + END IF + END IF + CALL POPCONTROL3B(branch) + END + diff --git a/BLAS/src/strsv_bv.f b/BLAS/src/strsv_bv.f new file mode 100644 index 0000000..89a5d36 --- /dev/null +++ b/BLAS/src/strsv_bv.f @@ -0,0 +1,746 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of strsv in reverse (adjoint) mode (with options multiDirectional): +C gradient of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:out +C> \brief \b STRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C REAL A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> STRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**T*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is REAL array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is REAL array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== + SUBROUTINE STRSV_BV(uplo, trans, diag, n, a, ab, lda, x, xb, incx + + , nbdirs) + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' +C Hint: ISIZE2OFa should be the size of dimension 2 of array a +C Hint: nbdirsmax should be the maximum number of differentiation directions +C +C -- Reference BLAS level2 routine -- +C -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +C +C .. Scalar Arguments .. + INTEGER incx, lda, n + CHARACTER diag, trans, uplo +C .. +C .. Array Arguments .. + REAL a(lda, *), x(*) + REAL ab(nbdirsmax, lda, *), xb(nbdirsmax, *) +C .. +C +C ===================================================================== +C .. +C .. Local Scalars .. + REAL temp + REAL tempb(nbdirsmax) + INTEGER i, info, ix, j, jx, kx + LOGICAL nounit + EXTERNAL LSAME + INTEGER ISIZE2OFA +C .. +C .. External Functions .. + INTEGER get_ISIZE2OFA + EXTERNAL get_ISIZE2OFA + LOGICAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, check_ISIZE2OFA_initialized +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX + INTEGER max1 + INTEGER nd + REAL tempb0(nbdirsmax) + INTEGER ad_from + INTEGER*4 branch + INTEGER ad_from0 + INTEGER ad_from1 + INTEGER ad_from2 + INTEGER ad_to + INTEGER ad_to0 + INTEGER ad_to1 + INTEGER ad_to2 + INTEGER ii2 + INTEGER ii1 + INTEGER nbdirs +C .. +C +C Test the input parameters. +C +C Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) + CALL check_ISIZE2OFA_initialized() + ISIZE2OFA = get_ISIZE2OFA() + IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, + + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' + STOP 1 + END IF +C + info = 0 + IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN + CALL PUSHCONTROL3B(0) + info = 1 + ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) + + .AND. (.NOT.LSAME(trans, 'C'))) THEN + CALL PUSHCONTROL3B(1) + info = 2 + ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN + CALL PUSHCONTROL3B(2) + info = 3 + ELSE IF (n .LT. 0) THEN + CALL PUSHCONTROL3B(3) + info = 4 + ELSE + IF (1 .LT. n) THEN + max1 = n + ELSE + max1 = 1 + END IF + IF (lda .LT. max1) THEN + CALL PUSHCONTROL3B(4) + info = 6 + ELSE IF (incx .EQ. 0) THEN + CALL PUSHCONTROL3B(5) + info = 8 + ELSE + CALL PUSHCONTROL3B(5) + END IF + END IF + IF (info .EQ. 0) THEN +C +C Quick return if possible. +C + IF (n .EQ. 0) THEN + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + ELSE +C + nounit = LSAME(diag, 'N') +C +C Set up the start point in X if the increment is not unity. This +C will be ( N - 1 )*INCX too small for descending loops. +C + IF (incx .LE. 0) THEN + CALL PUSHCONTROL1B(0) + kx = 1 - (n-1)*incx + ELSE IF (incx .NE. 1) THEN + CALL PUSHCONTROL1B(1) + kx = 1 + ELSE + CALL PUSHCONTROL1B(1) + END IF +C +C Start the operations. In this version the elements of A are +C accessed sequentially with one pass through A. +C + IF (LSAME(trans, 'N')) THEN +C +C Form x := inv( A )*x. +C + IF (LSAME(uplo, 'U')) THEN + IF (incx .EQ. 1) THEN + DO j=n,1,-1 + IF (nounit) THEN + CALL PUSHREAL4(x(j)) + x(j) = x(j)/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(temp) + temp = x(j) + ad_from = j - 1 + DO i=ad_from,1,-1 + CALL PUSHREAL4(x(i)) + x(i) = x(i) - temp*a(i, j) + ENDDO + CALL PUSHINTEGER4(ad_from) + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + DO j=1,n,1 + DO nd=1,nbdirsmax + tempb(nd) = 0.0 + ENDDO + CALL POPINTEGER4(ad_from) + DO i=1,ad_from,1 + CALL POPREAL4(x(i)) + DO nd=1,nbdirs + tempb(nd) = tempb(nd) - a(i, j)*xb(nd, i) + ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, i) + ENDDO + ENDDO + CALL POPREAL4(temp) + DO nd=1,nbdirs + xb(nd, j) = xb(nd, j) + tempb(nd) + ENDDO + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(x(j)) + DO nd=1,nbdirs + tempb0(nd) = xb(nd, j)/a(j, j) + xb(nd, j) = tempb0(nd) + ab(nd, j, j) = ab(nd, j, j) - x(j)*tempb0(nd)/a(j + + , j) + ENDDO + END IF + ENDDO + ELSE + jx = kx + (n-1)*incx + DO j=n,1,-1 + IF (nounit) THEN + CALL PUSHREAL4(x(jx)) + x(jx) = x(jx)/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(temp) + temp = x(jx) + CALL PUSHINTEGER4(ix) + ix = jx + ad_from0 = j - 1 + DO i=ad_from0,1,-1 + CALL PUSHINTEGER4(ix) + ix = ix - incx + CALL PUSHREAL4(x(ix)) + x(ix) = x(ix) - temp*a(i, j) + ENDDO + CALL PUSHINTEGER4(ad_from0) + CALL PUSHINTEGER4(jx) + jx = jx - incx + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + DO j=1,n,1 + CALL POPINTEGER4(jx) + DO nd=1,nbdirsmax + tempb(nd) = 0.0 + ENDDO + CALL POPINTEGER4(ad_from0) + DO i=1,ad_from0,1 + DO nd=1,nbdirs + tempb(nd) = tempb(nd) - a(i, j)*xb(nd, ix) + ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, ix) + ENDDO + CALL POPREAL4(x(ix)) + CALL POPINTEGER4(ix) + ENDDO + CALL POPINTEGER4(ix) + CALL POPREAL4(temp) + DO nd=1,nbdirs + xb(nd, jx) = xb(nd, jx) + tempb(nd) + ENDDO + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(x(jx)) + DO nd=1,nbdirs + tempb0(nd) = xb(nd, jx)/a(j, j) + xb(nd, jx) = tempb0(nd) + ab(nd, j, j) = ab(nd, j, j) - x(jx)*tempb0(nd)/a(j + + , j) + ENDDO + END IF + ENDDO + END IF + ELSE IF (incx .EQ. 1) THEN + DO j=1,n + IF (nounit) THEN + CALL PUSHREAL4(x(j)) + x(j) = x(j)/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(temp) + temp = x(j) + ad_from1 = j + 1 + DO i=ad_from1,n + CALL PUSHREAL4(x(i)) + x(i) = x(i) - temp*a(i, j) + ENDDO + CALL PUSHINTEGER4(ad_from1) + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + DO j=n,1,-1 + DO nd=1,nbdirsmax + tempb(nd) = 0.0 + ENDDO + CALL POPINTEGER4(ad_from1) + DO i=n,ad_from1,-1 + CALL POPREAL4(x(i)) + DO nd=1,nbdirs + tempb(nd) = tempb(nd) - a(i, j)*xb(nd, i) + ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, i) + ENDDO + ENDDO + CALL POPREAL4(temp) + DO nd=1,nbdirs + xb(nd, j) = xb(nd, j) + tempb(nd) + ENDDO + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(x(j)) + DO nd=1,nbdirs + tempb0(nd) = xb(nd, j)/a(j, j) + xb(nd, j) = tempb0(nd) + ab(nd, j, j) = ab(nd, j, j) - x(j)*tempb0(nd)/a(j, j + + ) + ENDDO + END IF + ENDDO + ELSE + jx = kx + DO j=1,n + IF (nounit) THEN + CALL PUSHREAL4(x(jx)) + x(jx) = x(jx)/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(temp) + temp = x(jx) + CALL PUSHINTEGER4(ix) + ix = jx + ad_from2 = j + 1 + DO i=ad_from2,n + CALL PUSHINTEGER4(ix) + ix = ix + incx + CALL PUSHREAL4(x(ix)) + x(ix) = x(ix) - temp*a(i, j) + ENDDO + CALL PUSHINTEGER4(ad_from2) + CALL PUSHINTEGER4(jx) + jx = jx + incx + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + DO j=n,1,-1 + CALL POPINTEGER4(jx) + DO nd=1,nbdirsmax + tempb(nd) = 0.0 + ENDDO + CALL POPINTEGER4(ad_from2) + DO i=n,ad_from2,-1 + DO nd=1,nbdirs + tempb(nd) = tempb(nd) - a(i, j)*xb(nd, ix) + ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, ix) + ENDDO + CALL POPREAL4(x(ix)) + CALL POPINTEGER4(ix) + ENDDO + CALL POPINTEGER4(ix) + CALL POPREAL4(temp) + DO nd=1,nbdirs + xb(nd, jx) = xb(nd, jx) + tempb(nd) + ENDDO + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(x(jx)) + DO nd=1,nbdirs + tempb0(nd) = xb(nd, jx)/a(j, j) + xb(nd, jx) = tempb0(nd) + ab(nd, j, j) = ab(nd, j, j) - x(jx)*tempb0(nd)/a(j, + + j) + ENDDO + END IF + ENDDO + END IF + ELSE IF (LSAME(uplo, 'U')) THEN +C +C Form x := inv( A**T )*x. +C + IF (incx .EQ. 1) THEN + DO j=1,n + temp = x(j) + DO i=1,j-1 + temp = temp - a(i, j)*x(i) + ENDDO + CALL PUSHINTEGER4(i - 1) + IF (nounit) THEN + CALL PUSHREAL4(temp) + temp = temp/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(x(j)) + x(j) = temp + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + DO j=n,1,-1 + CALL POPREAL4(x(j)) + DO nd=1,nbdirs + tempb(nd) = xb(nd, j) + xb(nd, j) = 0.0 + ENDDO + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(temp) + DO nd=1,nbdirs + tempb(nd) = tempb0(nd) + ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j + + ) + ENDDO + END IF + CALL POPINTEGER4(ad_to) + DO i=ad_to,1,-1 + DO nd=1,nbdirs + ab(nd, i, j) = ab(nd, i, j) - x(i)*tempb(nd) + xb(nd, i) = xb(nd, i) - a(i, j)*tempb(nd) + ENDDO + ENDDO + DO nd=1,nbdirs + xb(nd, j) = xb(nd, j) + tempb(nd) + ENDDO + ENDDO + ELSE + jx = kx + DO j=1,n + temp = x(jx) + ix = kx + DO i=1,j-1 + temp = temp - a(i, j)*x(ix) + CALL PUSHINTEGER4(ix) + ix = ix + incx + ENDDO + CALL PUSHINTEGER4(i - 1) + IF (nounit) THEN + CALL PUSHREAL4(temp) + temp = temp/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(x(jx)) + x(jx) = temp + CALL PUSHINTEGER4(jx) + jx = jx + incx + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + DO j=n,1,-1 + CALL POPINTEGER4(jx) + CALL POPREAL4(x(jx)) + DO nd=1,nbdirs + tempb(nd) = xb(nd, jx) + xb(nd, jx) = 0.0 + ENDDO + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(temp) + DO nd=1,nbdirs + tempb(nd) = tempb0(nd) + ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j + + ) + ENDDO + END IF + CALL POPINTEGER4(ad_to0) + DO i=ad_to0,1,-1 + CALL POPINTEGER4(ix) + DO nd=1,nbdirs + ab(nd, i, j) = ab(nd, i, j) - x(ix)*tempb(nd) + xb(nd, ix) = xb(nd, ix) - a(i, j)*tempb(nd) + ENDDO + ENDDO + DO nd=1,nbdirs + xb(nd, jx) = xb(nd, jx) + tempb(nd) + ENDDO + ENDDO + END IF + ELSE IF (incx .EQ. 1) THEN + DO j=n,1,-1 + temp = x(j) + DO i=n,j+1,-1 + temp = temp - a(i, j)*x(i) + ENDDO + CALL PUSHINTEGER4(i + 1) + IF (nounit) THEN + CALL PUSHREAL4(temp) + temp = temp/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(x(j)) + x(j) = temp + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + DO j=1,n,1 + CALL POPREAL4(x(j)) + DO nd=1,nbdirs + tempb(nd) = xb(nd, j) + xb(nd, j) = 0.0 + ENDDO + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(temp) + DO nd=1,nbdirs + tempb(nd) = tempb0(nd) + ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j) + ENDDO + END IF + CALL POPINTEGER4(ad_to1) + DO i=ad_to1,n,1 + DO nd=1,nbdirs + ab(nd, i, j) = ab(nd, i, j) - x(i)*tempb(nd) + xb(nd, i) = xb(nd, i) - a(i, j)*tempb(nd) + ENDDO + ENDDO + DO nd=1,nbdirs + xb(nd, j) = xb(nd, j) + tempb(nd) + ENDDO + ENDDO + ELSE + kx = kx + (n-1)*incx + jx = kx + DO j=n,1,-1 + temp = x(jx) + ix = kx + DO i=n,j+1,-1 + temp = temp - a(i, j)*x(ix) + CALL PUSHINTEGER4(ix) + ix = ix - incx + ENDDO + CALL PUSHINTEGER4(i + 1) + IF (nounit) THEN + CALL PUSHREAL4(temp) + temp = temp/a(j, j) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL4(x(jx)) + x(jx) = temp + CALL PUSHINTEGER4(jx) + jx = jx - incx + ENDDO + DO ii1=1,ISIZE2OFa + DO ii2=1,lda + DO nd=1,nbdirsmax + ab(nd, ii2, ii1) = 0.0 + ENDDO + ENDDO + ENDDO + DO j=1,n,1 + CALL POPINTEGER4(jx) + CALL POPREAL4(x(jx)) + DO nd=1,nbdirs + tempb(nd) = xb(nd, jx) + xb(nd, jx) = 0.0 + ENDDO + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL4(temp) + DO nd=1,nbdirs + tempb(nd) = tempb0(nd) + ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j) + ENDDO + END IF + CALL POPINTEGER4(ad_to2) + DO i=ad_to2,n,1 + CALL POPINTEGER4(ix) + DO nd=1,nbdirs + ab(nd, i, j) = ab(nd, i, j) - x(ix)*tempb(nd) + xb(nd, ix) = xb(nd, ix) - a(i, j)*tempb(nd) + ENDDO + ENDDO + DO nd=1,nbdirs + xb(nd, jx) = xb(nd, jx) + tempb(nd) + ENDDO + ENDDO + END IF + CALL POPCONTROL1B(branch) + END IF + END IF + CALL POPCONTROL3B(branch) + END + diff --git a/BLAS/src/strsv_d.f b/BLAS/src/strsv_d.f new file mode 100644 index 0000000..b7a8f9b --- /dev/null +++ b/BLAS/src/strsv_d.f @@ -0,0 +1,397 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of strsv in forward (tangent) mode: +C variations of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:in +C> \brief \b STRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C REAL A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> STRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**T*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is REAL array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is REAL array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== + SUBROUTINE STRSV_D(uplo, trans, diag, n, a, ad, lda, x, xd, incx) + IMPLICIT NONE +C +C -- Reference BLAS level2 routine -- +C -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +C +C .. Scalar Arguments .. + INTEGER incx, lda, n + CHARACTER diag, trans, uplo +C .. +C .. Array Arguments .. + REAL a(lda, *), x(*) + REAL ad(lda, *), xd(*) +C .. +C +C ===================================================================== +C .. +C .. Local Scalars .. + REAL temp + REAL tempd + INTEGER i, info, ix, j, jx, kx + LOGICAL nounit + EXTERNAL LSAME +C .. +C .. External Functions .. + LOGICAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX + INTEGER max1 + REAL temp0 +C .. +C +C Test the input parameters. +C + info = 0 + IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN + info = 1 + ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) + + .AND. (.NOT.LSAME(trans, 'C'))) THEN + info = 2 + ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN + info = 3 + ELSE IF (n .LT. 0) THEN + info = 4 + ELSE + IF (1 .LT. n) THEN + max1 = n + ELSE + max1 = 1 + END IF + IF (lda .LT. max1) THEN + info = 6 + ELSE IF (incx .EQ. 0) THEN + info = 8 + END IF + END IF + IF (info .NE. 0) THEN + CALL XERBLA('STRSV ', info) + RETURN + ELSE IF (n .EQ. 0) THEN +C +C Quick return if possible. +C + RETURN + ELSE +C + nounit = LSAME(diag, 'N') +C +C Set up the start point in X if the increment is not unity. This +C will be ( N - 1 )*INCX too small for descending loops. +C + IF (incx .LE. 0) THEN + kx = 1 - (n-1)*incx + ELSE IF (incx .NE. 1) THEN + kx = 1 + END IF +C +C Start the operations. In this version the elements of A are +C accessed sequentially with one pass through A. +C + IF (LSAME(trans, 'N')) THEN +C +C Form x := inv( A )*x. +C + IF (LSAME(uplo, 'U')) THEN + IF (incx .EQ. 1) THEN + DO j=n,1,-1 + IF (nounit) THEN + temp0 = x(j)/a(j, j) + xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) + x(j) = temp0 + END IF + tempd = xd(j) + temp = x(j) + DO i=j-1,1,-1 + xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) + x(i) = x(i) - temp*a(i, j) + ENDDO + ENDDO + ELSE + jx = kx + (n-1)*incx + DO j=n,1,-1 + IF (nounit) THEN + temp0 = x(jx)/a(j, j) + xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) + x(jx) = temp0 + END IF + tempd = xd(jx) + temp = x(jx) + ix = jx + DO i=j-1,1,-1 + ix = ix - incx + xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) + x(ix) = x(ix) - temp*a(i, j) + ENDDO + jx = jx - incx + ENDDO + END IF + ELSE IF (incx .EQ. 1) THEN + DO j=1,n + IF (nounit) THEN + temp0 = x(j)/a(j, j) + xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) + x(j) = temp0 + END IF + tempd = xd(j) + temp = x(j) + DO i=j+1,n + xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) + x(i) = x(i) - temp*a(i, j) + ENDDO + ENDDO + ELSE + jx = kx + DO j=1,n + IF (nounit) THEN + temp0 = x(jx)/a(j, j) + xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) + x(jx) = temp0 + END IF + tempd = xd(jx) + temp = x(jx) + ix = jx + DO i=j+1,n + ix = ix + incx + xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) + x(ix) = x(ix) - temp*a(i, j) + ENDDO + jx = jx + incx + ENDDO + END IF + ELSE IF (LSAME(uplo, 'U')) THEN +C +C Form x := inv( A**T )*x. +C + IF (incx .EQ. 1) THEN + DO j=1,n + tempd = xd(j) + temp = x(j) + DO i=1,j-1 + tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) + temp = temp - a(i, j)*x(i) + ENDDO + IF (nounit) THEN + temp0 = temp/a(j, j) + tempd = (tempd-temp0*ad(j, j))/a(j, j) + temp = temp0 + END IF + xd(j) = tempd + x(j) = temp + ENDDO + ELSE + jx = kx + DO j=1,n + tempd = xd(jx) + temp = x(jx) + ix = kx + DO i=1,j-1 + tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) + temp = temp - a(i, j)*x(ix) + ix = ix + incx + ENDDO + IF (nounit) THEN + temp0 = temp/a(j, j) + tempd = (tempd-temp0*ad(j, j))/a(j, j) + temp = temp0 + END IF + xd(jx) = tempd + x(jx) = temp + jx = jx + incx + ENDDO + END IF + ELSE IF (incx .EQ. 1) THEN + DO j=n,1,-1 + tempd = xd(j) + temp = x(j) + DO i=n,j+1,-1 + tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) + temp = temp - a(i, j)*x(i) + ENDDO + IF (nounit) THEN + temp0 = temp/a(j, j) + tempd = (tempd-temp0*ad(j, j))/a(j, j) + temp = temp0 + END IF + xd(j) = tempd + x(j) = temp + ENDDO + ELSE + kx = kx + (n-1)*incx + jx = kx + DO j=n,1,-1 + tempd = xd(jx) + temp = x(jx) + ix = kx + DO i=n,j+1,-1 + tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) + temp = temp - a(i, j)*x(ix) + ix = ix - incx + ENDDO + IF (nounit) THEN + temp0 = temp/a(j, j) + tempd = (tempd-temp0*ad(j, j))/a(j, j) + temp = temp0 + END IF + xd(jx) = tempd + x(jx) = temp + jx = jx - incx + ENDDO + END IF +C + RETURN +C +C End of STRSV +C + END IF + END + diff --git a/BLAS/src/strsv_dv.f b/BLAS/src/strsv_dv.f new file mode 100644 index 0000000..8fa7dd4 --- /dev/null +++ b/BLAS/src/strsv_dv.f @@ -0,0 +1,473 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of strsv in forward (tangent) mode (with options multiDirectional): +C variations of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:in +C> \brief \b STRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C REAL A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> STRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**T*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is REAL array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is REAL array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== + SUBROUTINE STRSV_DV(uplo, trans, diag, n, a, ad, lda, x, xd, incx + + , nbdirs) + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' +C Hint: nbdirsmax should be the maximum number of differentiation directions +C +C -- Reference BLAS level2 routine -- +C -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +C +C .. Scalar Arguments .. + INTEGER incx, lda, n + CHARACTER diag, trans, uplo +C .. +C .. Array Arguments .. + REAL a(lda, *), x(*) + REAL ad(nbdirsmax, lda, *), xd(nbdirsmax, *) +C .. +C +C ===================================================================== +C .. +C .. Local Scalars .. + REAL temp + REAL tempd(nbdirsmax) + INTEGER i, info, ix, j, jx, kx + LOGICAL nounit + EXTERNAL LSAME +C .. +C .. External Functions .. + LOGICAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX + INTEGER max1 + INTEGER nd + REAL temp0 + INTEGER nbdirs +C .. +C +C Test the input parameters. +C +C Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) + IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, + + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' + STOP 1 + END IF +C + info = 0 + IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN + info = 1 + ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) + + .AND. (.NOT.LSAME(trans, 'C'))) THEN + info = 2 + ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN + info = 3 + ELSE IF (n .LT. 0) THEN + info = 4 + ELSE + IF (1 .LT. n) THEN + max1 = n + ELSE + max1 = 1 + END IF + IF (lda .LT. max1) THEN + info = 6 + ELSE IF (incx .EQ. 0) THEN + info = 8 + END IF + END IF + IF (info .NE. 0) THEN + CALL XERBLA('STRSV ', info) + RETURN + ELSE IF (n .EQ. 0) THEN +C +C Quick return if possible. +C + RETURN + ELSE +C + nounit = LSAME(diag, 'N') +C +C Set up the start point in X if the increment is not unity. This +C will be ( N - 1 )*INCX too small for descending loops. +C + IF (incx .LE. 0) THEN + kx = 1 - (n-1)*incx + ELSE IF (incx .NE. 1) THEN + kx = 1 + END IF +C +C Start the operations. In this version the elements of A are +C accessed sequentially with one pass through A. +C + IF (LSAME(trans, 'N')) THEN +C +C Form x := inv( A )*x. +C + IF (LSAME(uplo, 'U')) THEN + IF (incx .EQ. 1) THEN + DO j=n,1,-1 + IF (nounit) THEN + temp0 = x(j)/a(j, j) + DO nd=1,nbdirs + xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) + ENDDO + x(j) = temp0 + END IF + DO nd=1,nbdirs + tempd(nd) = xd(nd, j) + ENDDO + temp = x(j) + DO i=j-1,1,-1 + DO nd=1,nbdirs + xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad( + + nd, i, j) + ENDDO + x(i) = x(i) - temp*a(i, j) + ENDDO + ENDDO + ELSE + jx = kx + (n-1)*incx + DO j=n,1,-1 + IF (nounit) THEN + temp0 = x(jx)/a(j, j) + DO nd=1,nbdirs + xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) + ENDDO + x(jx) = temp0 + END IF + DO nd=1,nbdirs + tempd(nd) = xd(nd, jx) + ENDDO + temp = x(jx) + ix = jx + DO i=j-1,1,-1 + ix = ix - incx + DO nd=1,nbdirs + xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp* + + ad(nd, i, j) + ENDDO + x(ix) = x(ix) - temp*a(i, j) + ENDDO + jx = jx - incx + ENDDO + END IF + ELSE IF (incx .EQ. 1) THEN + DO j=1,n + IF (nounit) THEN + temp0 = x(j)/a(j, j) + DO nd=1,nbdirs + xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) + ENDDO + x(j) = temp0 + END IF + DO nd=1,nbdirs + tempd(nd) = xd(nd, j) + ENDDO + temp = x(j) + DO i=j+1,n + DO nd=1,nbdirs + xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad(nd + + , i, j) + ENDDO + x(i) = x(i) - temp*a(i, j) + ENDDO + ENDDO + ELSE + jx = kx + DO j=1,n + IF (nounit) THEN + temp0 = x(jx)/a(j, j) + DO nd=1,nbdirs + xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) + ENDDO + x(jx) = temp0 + END IF + DO nd=1,nbdirs + tempd(nd) = xd(nd, jx) + ENDDO + temp = x(jx) + ix = jx + DO i=j+1,n + ix = ix + incx + DO nd=1,nbdirs + xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp*ad( + + nd, i, j) + ENDDO + x(ix) = x(ix) - temp*a(i, j) + ENDDO + jx = jx + incx + ENDDO + END IF + ELSE IF (LSAME(uplo, 'U')) THEN +C +C Form x := inv( A**T )*x. +C + IF (incx .EQ. 1) THEN + DO j=1,n + DO nd=1,nbdirs + tempd(nd) = xd(nd, j) + ENDDO + temp = x(j) + DO i=1,j-1 + DO nd=1,nbdirs + tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd + + (nd, i) + ENDDO + temp = temp - a(i, j)*x(i) + ENDDO + IF (nounit) THEN + temp0 = temp/a(j, j) + DO nd=1,nbdirs + tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) + ENDDO + temp = temp0 + END IF + DO nd=1,nbdirs + xd(nd, j) = tempd(nd) + ENDDO + x(j) = temp + ENDDO + ELSE + jx = kx + DO j=1,n + DO nd=1,nbdirs + tempd(nd) = xd(nd, jx) + ENDDO + temp = x(jx) + ix = kx + DO i=1,j-1 + DO nd=1,nbdirs + tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)* + + xd(nd, ix) + ENDDO + temp = temp - a(i, j)*x(ix) + ix = ix + incx + ENDDO + IF (nounit) THEN + temp0 = temp/a(j, j) + DO nd=1,nbdirs + tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) + ENDDO + temp = temp0 + END IF + DO nd=1,nbdirs + xd(nd, jx) = tempd(nd) + ENDDO + x(jx) = temp + jx = jx + incx + ENDDO + END IF + ELSE IF (incx .EQ. 1) THEN + DO j=n,1,-1 + DO nd=1,nbdirs + tempd(nd) = xd(nd, j) + ENDDO + temp = x(j) + DO i=n,j+1,-1 + DO nd=1,nbdirs + tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd( + + nd, i) + ENDDO + temp = temp - a(i, j)*x(i) + ENDDO + IF (nounit) THEN + temp0 = temp/a(j, j) + DO nd=1,nbdirs + tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) + ENDDO + temp = temp0 + END IF + DO nd=1,nbdirs + xd(nd, j) = tempd(nd) + ENDDO + x(j) = temp + ENDDO + ELSE + kx = kx + (n-1)*incx + jx = kx + DO j=n,1,-1 + DO nd=1,nbdirs + tempd(nd) = xd(nd, jx) + ENDDO + temp = x(jx) + ix = kx + DO i=n,j+1,-1 + DO nd=1,nbdirs + tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)*xd( + + nd, ix) + ENDDO + temp = temp - a(i, j)*x(ix) + ix = ix - incx + ENDDO + IF (nounit) THEN + temp0 = temp/a(j, j) + DO nd=1,nbdirs + tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) + ENDDO + temp = temp0 + END IF + DO nd=1,nbdirs + xd(nd, jx) = tempd(nd) + ENDDO + x(jx) = temp + jx = jx - incx + ENDDO + END IF +C + RETURN +C +C End of STRSV +C + END IF + END + diff --git a/BLAS/test/test_dtrsv.f90 b/BLAS/test/test_dtrsv.f90 new file mode 100644 index 0000000..4ff5db2 --- /dev/null +++ b/BLAS/test/test_dtrsv.f90 @@ -0,0 +1,180 @@ +! Test program for DTRSV differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision + +program test_dtrsv + implicit none + + integer :: seed_array(33) + + external :: dtrsv + external :: dtrsv_d + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: uplo + character :: trans + character :: diag + integer :: nsize + real(8), dimension(max_size,max_size) :: a + integer :: lda_val + real(8), dimension(max_size) :: x + integer :: incx_val + + ! Derivative variables + real(8), dimension(max_size,max_size) :: a_d + real(8), dimension(max_size) :: x_d + + ! Storage variables for inout parameters + real(8), dimension(max_size) :: x_output + + ! Array restoration variables for numerical differentiation + real(8), dimension(max_size) :: x_orig + real(8), dimension(max_size,max_size) :: a_orig + + ! Variables for central difference computation + real(8), dimension(max_size) :: x_forward, x_backward + ! Scalar variables for central difference computation + real(8) :: central_diff, ad_result + logical :: has_large_errors + + ! Variables for storing original derivative values + real(8), dimension(max_size,max_size) :: a_d_orig + real(8), dimension(max_size) :: x_d_orig + + ! Temporary variables for matrix initialization + real(4) :: temp_real, temp_imag + integer :: i, j + + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + call random_number(a) + a = a * 2.0d0 - 1.0d0 ! Scale to [-1,1] + lda_val = lda ! LDA must be at least max( 1 + call random_number(x) + x = x * 2.0d0 - 1.0d0 ! Scale to [-1,1] + incx_val = 1 ! INCX 1 + + ! Initialize input derivatives to random values + call random_number(x_d) + x_d = x_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + call random_number(a_d) + a_d = a_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + + ! Store initial derivative values after random initialization + a_d_orig = a_d + x_d_orig = x_d + + ! Store original values for central difference computation + x_orig = x + a_orig = a + + write(*,*) 'Testing DTRSV' + ! Store input values of inout parameters before first function call + x_orig = x + + ! Re-initialize data for differentiated function + ! Only reinitialize inout parameters - keep input-only parameters unchanged + + ! uplo already has correct value from original call + ! trans already has correct value from original call + ! diag already has correct value from original call + nsize = n + ! a already has correct value from original call + lda_val = lda ! LDA must be at least max( 1 + x = x_orig + incx_val = 1 ! INCX 1 + + ! Call the differentiated function + call dtrsv_d(uplo, trans, diag, nsize, a, a_d, lda_val, x, x_d, incx_val) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(8), parameter :: h = 1.0e-6 ! Step size for finite differences + real(8) :: relative_error, max_error + real(8) :: output_orig, output_pert + real(8) :: numerical_result, analytical_result + real(8) :: abs_error, abs_reference, error_bound + integer :: i, j + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5 + + ! Original values already stored in main program + + ! Central difference computation: f(x + h) - f(x - h) / (2h) + ! Forward perturbation: f(x + h) + x = x_orig + h * x_d_orig + a = a_orig + h * a_d_orig + call dtrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + ! Store forward perturbation results + x_forward = x + + ! Backward perturbation: f(x - h) + x = x_orig - h * x_d_orig + a = a_orig - h * a_d_orig + call dtrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + ! Store backward perturbation results + x_backward = x + + ! Compute central differences and compare with AD results + ! Check derivatives for output X + do i = 1, min(2, n) ! Check only first few elements + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (x_forward(i) - x_backward(i)) / (2.0e0 * h) + ! AD result + ad_result = x_d(i) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) 'Large error in output X(', i, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_dtrsv diff --git a/BLAS/test/test_dtrsv_reverse.f90 b/BLAS/test/test_dtrsv_reverse.f90 new file mode 100644 index 0000000..667d3da --- /dev/null +++ b/BLAS/test/test_dtrsv_reverse.f90 @@ -0,0 +1,231 @@ +! Test program for DTRSV reverse mode (adjoint) differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision +! Verification uses VJP methodology with finite differences + +program test_dtrsv_reverse + implicit none + + integer :: seed_array(33) + + external :: dtrsv + external :: dtrsv_b + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: uplo + character :: trans + character :: diag + integer :: nsize + real(8), dimension(max_size,max_size) :: a + integer :: lda_val + real(8), dimension(max_size) :: x + integer :: incx_val + + ! Adjoint variables (reverse mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + real(8), dimension(max_size,max_size) :: ab + real(8), dimension(max_size) :: xb + + ! Storage for original values (for VJP verification) + real(8), dimension(max_size,max_size) :: a_orig + real(8), dimension(max_size) :: x_orig + + ! Variables for VJP verification via finite differences + real(8), dimension(max_size) :: x_plus, x_minus + + ! Saved cotangents (output adjoints) for VJP verification + real(8), dimension(max_size) :: xb_orig + real(8), parameter :: h = 1.0e-7 + real(8) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + integer :: i, j + real(8), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + ! Initialize primal values + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + call random_number(a) + a = a * 2.0d0 - 1.0d0 + lda_val = lda + call random_number(x) + x = x * 2.0d0 - 1.0d0 + incx_val = 1 + + ! Store original primal values + a_orig = a + x_orig = x + + write(*,*) 'Testing DTRSV' + + ! Initialize output adjoints (cotangents) with random values + ! These are the 'seeds' for reverse mode + call random_number(xb) + xb = xb * 2.0d0 - 1.0d0 + + ! Save output adjoints (cotangents) for VJP verification + ! Note: output adjoints may be modified by reverse mode function + xb_orig = xb + + ! Initialize input adjoints to zero (they will be computed) + ab = 0.0d0 + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! Differentiated code checks they are set via check_ISIZE*_initialized. + call set_ISIZE2OFA(max_size) + + ! Call reverse mode differentiated function + call dtrsv_b(uplo, trans, diag, nsize, a, ab, lda_val, x, xb, incx_val) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + ! For reverse mode, we verify: cotangent^T @ J @ direction = direction^T @ adjoint + ! Equivalently: cotangent^T @ (f(x+h*dir) - f(x-h*dir))/(2h) should equal dir^T @ computed_adjoint + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing (like tangents in forward mode) + real(8), dimension(max_size,max_size) :: a_dir + real(8), dimension(max_size) :: x_dir + + real(8), dimension(max_size) :: x_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Initialize random direction vectors for all inputs + call random_number(a_dir) + a_dir = a_dir * 2.0d0 - 1.0d0 + call random_number(x_dir) + x_dir = x_dir * 2.0d0 - 1.0d0 + + ! Forward perturbation: f(x + h*dir) + a = a_orig + h * a_dir + x = x_orig + h * x_dir + call dtrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_plus = x + + ! Backward perturbation: f(x - h*dir) + a = a_orig - h * a_dir + x = x_orig - h * x_dir + call dtrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_minus = x + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + x_central_diff = (x_plus - x_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0d0 + ! Compute and sort products for x (FD) + n_products = n + do i = 1, n + temp_products(i) = xb_orig(i) * x_central_diff(i) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0d0 + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = a_dir(i,j) * ab(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for x + n_products = n + do i = 1, n + temp_products(i) = x_dir(i) * xb(i) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + max_error = relative_error + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(8), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(8) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_dtrsv_reverse diff --git a/BLAS/test/test_dtrsv_vector_forward.f90 b/BLAS/test/test_dtrsv_vector_forward.f90 new file mode 100644 index 0000000..3f4395f --- /dev/null +++ b/BLAS/test/test_dtrsv_vector_forward.f90 @@ -0,0 +1,160 @@ +! Test program for DTRSV vector forward mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision with nbdirsmax=4 + +program test_dtrsv_vector_forward + implicit none + include 'DIFFSIZES.inc' + + external :: dtrsv + external :: dtrsv_dv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, idir ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: uplo + character :: trans + character :: diag + integer :: nsize + real(8), dimension(max_size,max_size) :: a + integer :: lda_val + real(8), dimension(max_size) :: x + integer :: incx_val + + ! Vector mode derivative variables (type-promoted) + ! Scalars become arrays(nbdirsmax), arrays gain extra dimension + real(8), dimension(nbdirsmax,max_size,max_size) :: a_dv + real(8), dimension(nbdirsmax,max_size) :: x_dv + ! Declare variables for storing original values + real(8), dimension(max_size,max_size) :: a_orig + real(8), dimension(nbdirsmax,max_size,max_size) :: a_dv_orig + real(8), dimension(max_size) :: x_orig + real(8), dimension(nbdirsmax,max_size) :: x_dv_orig + + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize test parameters + nsize = n + lda_val = lda + incx_val = 1 + + ! Initialize test data with random numbers + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + uplo = 'U' + trans = 'N' + diag = 'N' + call random_number(a) + a = a * 2.0d0 - 1.0d0 ! Scale to [-1,1] + call random_number(x) + x = x * 2.0d0 - 1.0d0 ! Scale to [-1,1] + + ! Initialize input derivatives to random values (exactly like scalar mode) + do idir = 1, nbdirsmax + call random_number(a_dv(idir,:,:)) + a_dv(idir,:,:) = a_dv(idir,:,:) * 2.0d0 - 1.0d0 + end do + do idir = 1, nbdirsmax + call random_number(x_dv(idir,:)) + x_dv(idir,:) = x_dv(idir,:) * 2.0d0 - 1.0d0 + end do + + write(*,*) 'Testing DTRSV (Vector Forward Mode)' + ! Store original values before any function calls (critical for INOUT parameters) + a_orig = a + a_dv_orig = a_dv + x_orig = x + x_dv_orig = x_dv + + ! Call the vector mode differentiated function + + call dtrsv_dv(uplo, trans, diag, nsize, a, a_dv, lda_val, x, x_dv, incx_val, nbdirsmax) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Vector forward mode test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(8), parameter :: h = 1.0e-7 ! Step size for finite differences + real(8) :: relative_error, max_error + real(8) :: abs_error, abs_reference, error_bound + real(8) :: central_diff, ad_result + integer :: i, j, idir + logical :: has_large_errors + real(8), dimension(max_size) :: x_forward, x_backward + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + write(*,*) 'Number of directions:', nbdirsmax + + ! Test each derivative direction separately + do idir = 1, nbdirsmax + + ! Forward perturbation: f(x + h * direction) + a = a_orig + h * a_dv_orig(idir,:,:) + x = x_orig + h * x_dv_orig(idir,:) + call dtrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_forward = x + + ! Backward perturbation: f(x - h * direction) + a = a_orig - h * a_dv_orig(idir,:,:) + x = x_orig - h * x_dv_orig(idir,:) + call dtrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_backward = x + + ! Compute central differences and compare with AD results + do i = 1, min(2, nsize) ! Check only first few elements + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (x_forward(i) - x_backward(i)) / (2.0e0 * h) + ! AD result + ad_result = x_dv(idir,i) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) ' Large error in direction', idir, ' output X(', i, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_dtrsv_vector_forward \ No newline at end of file diff --git a/BLAS/test/test_dtrsv_vector_reverse.f90 b/BLAS/test/test_dtrsv_vector_reverse.f90 new file mode 100644 index 0000000..a53c79a --- /dev/null +++ b/BLAS/test/test_dtrsv_vector_reverse.f90 @@ -0,0 +1,235 @@ +! Test program for DTRSV vector reverse mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision with nbdirsmax=4 + +program test_dtrsv_vector_reverse + implicit none + include 'DIFFSIZES.inc' + + external :: dtrsv + external :: dtrsv_bv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, k ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: uplo + character :: trans + character :: diag + integer :: nsize + real(8), dimension(max_size,max_size) :: a + integer :: lda_val + real(8), dimension(max_size) :: x + integer :: incx_val + + ! Adjoint variables (reverse vector mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + real(8), dimension(nbdirsmax,max_size,max_size) :: ab + real(8), dimension(nbdirsmax,max_size) :: xb + + ! Storage for original cotangents (for INOUT parameters in VJP verification) + real(8), dimension(nbdirsmax,max_size) :: xb_orig + + ! Storage for original values (for VJP verification) + real(8), dimension(max_size,max_size) :: a_orig + real(8), dimension(max_size) :: x_orig + + ! Variables for VJP verification via finite differences + real(8), parameter :: h = 1.0e-7 + real(8) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + real(8), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize primal values + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + call random_number(a) + a = a * 2.0 - 1.0 + lda_val = lda + call random_number(x) + x = x * 2.0 - 1.0 + incx_val = 1 + + ! Store original primal values + a_orig = a + x_orig = x + + ! Initialize output adjoints (cotangents) with random values for each direction + ! These are the 'seeds' for reverse mode + do k = 1, nbdirsmax + call random_number(xb(k,:)) + xb(k,:) = xb(k,:) * 2.0 - 1.0 + end do + + ! Initialize input adjoints to zero (they will be computed) + ! Note: Inout parameters are skipped - they already have output adjoints initialized + ab = 0.0 + + ! Save original cotangent seeds for OUTPUT/INOUT parameters (before function call) + xb_orig = xb + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! ISIZE1OF* (vectors): use n to match adjoint array size; ISIZE2OF* (matrices): use max_size. + call set_ISIZE2OFA(max_size) + + ! Call reverse vector mode differentiated function + call dtrsv_bv(uplo, trans, diag, nsize, a, ab, lda_val, x, xb, incx_val, nbdirsmax) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing + real(8), dimension(max_size,max_size) :: a_dir + real(8), dimension(max_size) :: x_dir + real(8), dimension(max_size) :: x_plus, x_minus, x_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Test each differentiation direction separately + do k = 1, nbdirsmax + + ! Initialize random direction vectors for all inputs + call random_number(a_dir) + a_dir = a_dir * 2.0 - 1.0 + call random_number(x_dir) + x_dir = x_dir * 2.0 - 1.0 + + ! Forward perturbation: f(x + h*dir) + a = a_orig + h * a_dir + x = x_orig + h * x_dir + call dtrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_plus = x + + ! Backward perturbation: f(x - h*dir) + a = a_orig - h * a_dir + x = x_orig - h * x_dir + call dtrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_minus = x + + ! Compute central differences and VJP verification + ! VJP check: direction^T @ adjoint should equal finite difference + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + x_central_diff = (x_plus - x_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0d0 + ! Compute and sort products for x (FD) + n_products = n + do i = 1, n + temp_products(i) = xb_orig(k,i) * x_central_diff(i) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0d0 + ! Compute and sort products for x + n_products = n + do i = 1, n + temp_products(i) = x_dir(i) * xb(k,i) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = a_dir(i,j) * ab(k,i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + ! Compute relative error for reporting + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + if (relative_error > max_error) max_error = relative_error + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(8), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(8) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_dtrsv_vector_reverse \ No newline at end of file diff --git a/BLAS/test/test_strsm.f90 b/BLAS/test/test_strsm.f90 new file mode 100644 index 0000000..cd92503 --- /dev/null +++ b/BLAS/test/test_strsm.f90 @@ -0,0 +1,201 @@ +! Test program for STRSM differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision + +program test_strsm + implicit none + + integer :: seed_array(33) + + external :: strsm + external :: strsm_d + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + real(4) :: alpha + real(4), dimension(max_size,max_size) :: a + integer :: lda_val + real(4), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Derivative variables + real(4) :: alpha_d + real(4), dimension(max_size,max_size) :: a_d + real(4), dimension(max_size,max_size) :: b_d + + ! Storage variables for inout parameters + real(4), dimension(max_size,max_size) :: b_output + + ! Array restoration variables for numerical differentiation + real(4), dimension(max_size,max_size) :: b_orig + real(4), dimension(max_size,max_size) :: a_orig + real(4) :: alpha_orig + + ! Variables for central difference computation + real(4), dimension(max_size,max_size) :: b_forward, b_backward + ! Scalar variables for central difference computation + real(4) :: central_diff, ad_result + logical :: has_large_errors + + ! Variables for storing original derivative values + real(4), dimension(max_size,max_size) :: a_d_orig + real(4), dimension(max_size,max_size) :: b_d_orig + real(4) :: alpha_d_orig + + ! Temporary variables for matrix initialization + real(4) :: temp_real, temp_imag + integer :: i, j + + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(alpha) + alpha = alpha * 2.0 - 1.0 ! Scale to [-1,1] + call random_number(a) + a = a * 2.0d0 - 1.0d0 ! Scale to [-1,1] + lda_val = lda ! LDA must be at least max( 1 + call random_number(b) + b = b * 2.0d0 - 1.0d0 ! Scale to [-1,1] + ldb_val = ldb + + ! Initialize input derivatives to random values + call random_number(b_d) + b_d = b_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + call random_number(a_d) + a_d = a_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + call random_number(alpha_d) + alpha_d = alpha_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + + ! Store initial derivative values after random initialization + a_d_orig = a_d + b_d_orig = b_d + alpha_d_orig = alpha_d + + ! Store original values for central difference computation + b_orig = b + a_orig = a + alpha_orig = alpha + + write(*,*) 'Testing STRSM' + ! Store input values of inout parameters before first function call + b_orig = b + + ! Re-initialize data for differentiated function + ! Only reinitialize inout parameters - keep input-only parameters unchanged + + ! side already has correct value from original call + ! uplo already has correct value from original call + ! transa already has correct value from original call + ! diag already has correct value from original call + msize = n + nsize = n + ! alpha already has correct value from original call + ! a already has correct value from original call + lda_val = lda ! LDA must be at least max( 1 + b = b_orig + ldb_val = ldb + + ! Call the differentiated function + call strsm_d(side, uplo, transa, diag, msize, nsize, alpha, alpha_d, a, a_d, lda_val, b, b_d, ldb_val) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(4), parameter :: h = 1.0e-3 ! Step size for finite differences + real(4) :: relative_error, max_error + real(4) :: output_orig, output_pert + real(4) :: numerical_result, analytical_result + real(4) :: abs_error, abs_reference, error_bound + integer :: i, j + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3 + + ! Original values already stored in main program + + ! Central difference computation: f(x + h) - f(x - h) / (2h) + ! Forward perturbation: f(x + h) + b = b_orig + h * b_d_orig + a = a_orig + h * a_d_orig + alpha = alpha_orig + h * alpha_d_orig + call strsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + ! Store forward perturbation results + b_forward = b + + ! Backward perturbation: f(x - h) + b = b_orig - h * b_d_orig + a = a_orig - h * a_d_orig + alpha = alpha_orig - h * alpha_d_orig + call strsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + ! Store backward perturbation results + b_backward = b + + ! Compute central differences and compare with AD results + ! Check derivatives for output B + do j = 1, min(2, n) ! Check only first few elements + do i = 1, min(2, n) + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (b_forward(i,j) - b_backward(i,j)) / (2.0e0 * h) + ! AD result + ad_result = b_d(i,j) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 2.0e-3 + 2.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) 'Large error in output B(', i, ',', j, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_strsm diff --git a/BLAS/test/test_strsm_reverse.f90 b/BLAS/test/test_strsm_reverse.f90 new file mode 100644 index 0000000..b047110 --- /dev/null +++ b/BLAS/test/test_strsm_reverse.f90 @@ -0,0 +1,255 @@ +! Test program for STRSM reverse mode (adjoint) differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision +! Verification uses VJP methodology with finite differences + +program test_strsm_reverse + implicit none + + integer :: seed_array(33) + + external :: strsm + external :: strsm_b + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + real(4) :: alpha + real(4), dimension(max_size,max_size) :: a + integer :: lda_val + real(4), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Adjoint variables (reverse mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + real(4) :: alphab + real(4), dimension(max_size,max_size) :: ab + real(4), dimension(max_size,max_size) :: bb + + ! Storage for original values (for VJP verification) + real(4) :: alpha_orig + real(4), dimension(max_size,max_size) :: a_orig + real(4), dimension(max_size,max_size) :: b_orig + + ! Variables for VJP verification via finite differences + real(4), dimension(max_size,max_size) :: b_plus, b_minus + + ! Saved cotangents (output adjoints) for VJP verification + real(4), dimension(max_size,max_size) :: bb_orig + real(4), parameter :: h = 1.0e-3 + real(4) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + integer :: i, j + real(4), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize primal values + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(alpha) + alpha = alpha * 2.0 - 1.0 + call random_number(a) + a = a * 2.0d0 - 1.0d0 + lda_val = lda + call random_number(b) + b = b * 2.0d0 - 1.0d0 + ldb_val = ldb + + ! Store original primal values + alpha_orig = alpha + a_orig = a + b_orig = b + + write(*,*) 'Testing STRSM' + + ! Initialize output adjoints (cotangents) with random values + ! These are the 'seeds' for reverse mode + call random_number(bb) + bb = bb * 2.0 - 1.0 + + ! Save output adjoints (cotangents) for VJP verification + ! Note: output adjoints may be modified by reverse mode function + bb_orig = bb + + ! Initialize input adjoints to zero (they will be computed) + ab = 0.0 + alphab = 0.0 + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! Differentiated code checks they are set via check_ISIZE*_initialized. + call set_ISIZE2OFA(max_size) + + ! Call reverse mode differentiated function + call strsm_b(side, uplo, transa, diag, msize, nsize, alpha, alphab, a, ab, lda_val, b, bb, ldb_val) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + ! For reverse mode, we verify: cotangent^T @ J @ direction = direction^T @ adjoint + ! Equivalently: cotangent^T @ (f(x+h*dir) - f(x-h*dir))/(2h) should equal dir^T @ computed_adjoint + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing (like tangents in forward mode) + real(4) :: alpha_dir + real(4), dimension(max_size,max_size) :: a_dir + real(4), dimension(max_size,max_size) :: b_dir + + real(4), dimension(max_size,max_size) :: b_central_diff + + max_error = 0.0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Initialize random direction vectors for all inputs + call random_number(alpha_dir) + alpha_dir = alpha_dir * 2.0 - 1.0 + call random_number(a_dir) + a_dir = a_dir * 2.0 - 1.0 + call random_number(b_dir) + b_dir = b_dir * 2.0 - 1.0 + + ! Forward perturbation: f(x + h*dir) + alpha = alpha_orig + h * alpha_dir + a = a_orig + h * a_dir + b = b_orig + h * b_dir + call strsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_plus = b + + ! Backward perturbation: f(x - h*dir) + alpha = alpha_orig - h * alpha_dir + a = a_orig - h * a_dir + b = b_orig - h * b_dir + call strsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_minus = b + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + b_central_diff = (b_plus - b_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0 + ! Compute and sort products for b (FD) + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = bb_orig(i,j) * b_central_diff(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0 + vjp_ad = vjp_ad + alpha_dir * alphab + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = a_dir(i,j) * ab(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for b + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = b_dir(i,j) * bb(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 2.0e-3 + 2.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + max_error = relative_error + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(4), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(4) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_strsm_reverse diff --git a/BLAS/test/test_strsm_vector_forward.f90 b/BLAS/test/test_strsm_vector_forward.f90 new file mode 100644 index 0000000..bb17d13 --- /dev/null +++ b/BLAS/test/test_strsm_vector_forward.f90 @@ -0,0 +1,180 @@ +! Test program for STRSM vector forward mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision with nbdirsmax=4 + +program test_strsm_vector_forward + implicit none + include 'DIFFSIZES.inc' + + external :: strsm + external :: strsm_dv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, idir ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + real(4) :: alpha + real(4), dimension(max_size,max_size) :: a + integer :: lda_val + real(4), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Vector mode derivative variables (type-promoted) + ! Scalars become arrays(nbdirsmax), arrays gain extra dimension + real(4), dimension(nbdirsmax) :: alpha_dv + real(4), dimension(nbdirsmax,max_size,max_size) :: a_dv + real(4), dimension(nbdirsmax,max_size,max_size) :: b_dv + ! Declare variables for storing original values + real(4) :: alpha_orig + real(4), dimension(nbdirsmax) :: alpha_dv_orig + real(4), dimension(max_size,max_size) :: a_orig + real(4), dimension(nbdirsmax,max_size,max_size) :: a_dv_orig + real(4), dimension(max_size,max_size) :: b_orig + real(4), dimension(nbdirsmax,max_size,max_size) :: b_dv_orig + + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize test parameters + msize = n + nsize = n + lda_val = lda + ldb_val = ldb + + ! Initialize test data with random numbers + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + call random_number(alpha) + alpha = alpha * 2.0 - 1.0 ! Scale to [-1,1] + call random_number(a) + a = a * 2.0 - 1.0 ! Scale to [-1,1] + call random_number(b) + b = b * 2.0 - 1.0 ! Scale to [-1,1] + + ! Initialize input derivatives to random values (exactly like scalar mode) + do idir = 1, nbdirsmax + call random_number(temp_real) + alpha_dv(idir) = temp_real * 2.0 - 1.0 + end do + do idir = 1, nbdirsmax + call random_number(a_dv(idir,:,:)) + a_dv(idir,:,:) = a_dv(idir,:,:) * 2.0 - 1.0 + end do + do idir = 1, nbdirsmax + call random_number(b_dv(idir,:,:)) + b_dv(idir,:,:) = b_dv(idir,:,:) * 2.0 - 1.0 + end do + + write(*,*) 'Testing STRSM (Vector Forward Mode)' + ! Store original values before any function calls (critical for INOUT parameters) + alpha_orig = alpha + alpha_dv_orig = alpha_dv + a_orig = a + a_dv_orig = a_dv + b_orig = b + b_dv_orig = b_dv + + ! Call the vector mode differentiated function + + call strsm_dv(side, uplo, transa, diag, msize, nsize, alpha, alpha_dv, a, a_dv, lda_val, b, b_dv, ldb_val, nbdirsmax) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Vector forward mode test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(4), parameter :: h = 1.0e-3 ! Step size for finite differences + real(4) :: relative_error, max_error + real(4) :: abs_error, abs_reference, error_bound + real(4) :: central_diff, ad_result + integer :: i, j, idir + logical :: has_large_errors + real(4), dimension(max_size,max_size) :: b_forward, b_backward + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + write(*,*) 'Number of directions:', nbdirsmax + + ! Test each derivative direction separately + do idir = 1, nbdirsmax + + ! Forward perturbation: f(x + h * direction) + alpha = alpha_orig + h * alpha_dv_orig(idir) + a = a_orig + h * a_dv_orig(idir,:,:) + b = b_orig + h * b_dv_orig(idir,:,:) + call strsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_forward = b + + ! Backward perturbation: f(x - h * direction) + alpha = alpha_orig - h * alpha_dv_orig(idir) + a = a_orig - h * a_dv_orig(idir,:,:) + b = b_orig - h * b_dv_orig(idir,:,:) + call strsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_backward = b + + ! Compute central differences and compare with AD results + do j = 1, min(2, nsize) ! Check only first few elements + do i = 1, min(2, nsize) + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (b_forward(i,j) - b_backward(i,j)) / (2.0e0 * h) + ! AD result + ad_result = b_dv(idir,i,j) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 2.0e-3 + 2.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) ' Large error in direction', idir, ' output B(', i, ',', j, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_strsm_vector_forward \ No newline at end of file diff --git a/BLAS/test/test_strsm_vector_reverse.f90 b/BLAS/test/test_strsm_vector_reverse.f90 new file mode 100644 index 0000000..bdfe4da --- /dev/null +++ b/BLAS/test/test_strsm_vector_reverse.f90 @@ -0,0 +1,258 @@ +! Test program for STRSM vector reverse mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision with nbdirsmax=4 + +program test_strsm_vector_reverse + implicit none + include 'DIFFSIZES.inc' + + external :: strsm + external :: strsm_bv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, k ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + real(4) :: alpha + real(4), dimension(max_size,max_size) :: a + integer :: lda_val + real(4), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Adjoint variables (reverse vector mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + real(4), dimension(nbdirsmax) :: alphab + real(4), dimension(nbdirsmax,max_size,max_size) :: ab + real(4), dimension(nbdirsmax,max_size,max_size) :: bb + + ! Storage for original cotangents (for INOUT parameters in VJP verification) + real(4), dimension(nbdirsmax,max_size,max_size) :: bb_orig + + ! Storage for original values (for VJP verification) + real(4) :: alpha_orig + real(4), dimension(max_size,max_size) :: a_orig + real(4), dimension(max_size,max_size) :: b_orig + + ! Variables for VJP verification via finite differences + real(4), parameter :: h = 1.0e-3 + real(4) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + real(4), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize primal values + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(alpha) + alpha = alpha * 2.0 - 1.0 + call random_number(a) + a = a * 2.0 - 1.0 + lda_val = lda + call random_number(b) + b = b * 2.0 - 1.0 + ldb_val = ldb + + ! Store original primal values + alpha_orig = alpha + a_orig = a + b_orig = b + + ! Initialize output adjoints (cotangents) with random values for each direction + ! These are the 'seeds' for reverse mode + do k = 1, nbdirsmax + call random_number(bb(k,:,:)) + bb(k,:,:) = bb(k,:,:) * 2.0 - 1.0 + end do + + ! Initialize input adjoints to zero (they will be computed) + ! Note: Inout parameters are skipped - they already have output adjoints initialized + alphab = 0.0 + ab = 0.0 + + ! Save original cotangent seeds for OUTPUT/INOUT parameters (before function call) + bb_orig = bb + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! ISIZE1OF* (vectors): use n to match adjoint array size; ISIZE2OF* (matrices): use max_size. + call set_ISIZE2OFA(max_size) + + ! Call reverse vector mode differentiated function + call strsm_bv(side, uplo, transa, diag, msize, nsize, alpha, alphab, a, ab, lda_val, b, bb, ldb_val, nbdirsmax) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing + real(4) :: alpha_dir + real(4), dimension(max_size,max_size) :: a_dir + real(4), dimension(max_size,max_size) :: b_dir + real(4), dimension(max_size,max_size) :: b_plus, b_minus, b_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Test each differentiation direction separately + do k = 1, nbdirsmax + + ! Initialize random direction vectors for all inputs + call random_number(alpha_dir) + alpha_dir = alpha_dir * 2.0 - 1.0 + call random_number(a_dir) + a_dir = a_dir * 2.0 - 1.0 + call random_number(b_dir) + b_dir = b_dir * 2.0 - 1.0 + + ! Forward perturbation: f(x + h*dir) + alpha = alpha_orig + h * alpha_dir + a = a_orig + h * a_dir + b = b_orig + h * b_dir + call strsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_plus = b + + ! Backward perturbation: f(x - h*dir) + alpha = alpha_orig - h * alpha_dir + a = a_orig - h * a_dir + b = b_orig - h * b_dir + call strsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_minus = b + + ! Compute central differences and VJP verification + ! VJP check: direction^T @ adjoint should equal finite difference + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + b_central_diff = (b_plus - b_minus) / (2.0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0 + ! Compute and sort products for b (FD) + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = bb_orig(k,i,j) * b_central_diff(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0 + ! Compute and sort products for b + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = b_dir(i,j) * bb(k,i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = a_dir(i,j) * ab(k,i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + vjp_ad = vjp_ad + alpha_dir * alphab(k) + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 2.0e-3 + 2.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + ! Compute relative error for reporting + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + if (relative_error > max_error) max_error = relative_error + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(4), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(4) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_strsm_vector_reverse \ No newline at end of file diff --git a/BLAS/test/test_strsv.f90 b/BLAS/test/test_strsv.f90 new file mode 100644 index 0000000..284185e --- /dev/null +++ b/BLAS/test/test_strsv.f90 @@ -0,0 +1,180 @@ +! Test program for STRSV differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision + +program test_strsv + implicit none + + integer :: seed_array(33) + + external :: strsv + external :: strsv_d + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: uplo + character :: trans + character :: diag + integer :: nsize + real(4), dimension(max_size,max_size) :: a + integer :: lda_val + real(4), dimension(max_size) :: x + integer :: incx_val + + ! Derivative variables + real(4), dimension(max_size,max_size) :: a_d + real(4), dimension(max_size) :: x_d + + ! Storage variables for inout parameters + real(4), dimension(max_size) :: x_output + + ! Array restoration variables for numerical differentiation + real(4), dimension(max_size,max_size) :: a_orig + real(4), dimension(max_size) :: x_orig + + ! Variables for central difference computation + real(4), dimension(max_size) :: x_forward, x_backward + ! Scalar variables for central difference computation + real(4) :: central_diff, ad_result + logical :: has_large_errors + + ! Variables for storing original derivative values + real(4), dimension(max_size,max_size) :: a_d_orig + real(4), dimension(max_size) :: x_d_orig + + ! Temporary variables for matrix initialization + real(4) :: temp_real, temp_imag + integer :: i, j + + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + call random_number(a) + a = a * 2.0d0 - 1.0d0 ! Scale to [-1,1] + lda_val = lda ! LDA must be at least max( 1 + call random_number(x) + x = x * 2.0 - 1.0 ! Scale to [-1,1] + incx_val = 1 ! INCX 1 + + ! Initialize input derivatives to random values + call random_number(a_d) + a_d = a_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + call random_number(x_d) + x_d = x_d * 2.0e0 - 1.0e0 ! Scale to [-1,1] + + ! Store initial derivative values after random initialization + a_d_orig = a_d + x_d_orig = x_d + + ! Store original values for central difference computation + a_orig = a + x_orig = x + + write(*,*) 'Testing STRSV' + ! Store input values of inout parameters before first function call + x_orig = x + + ! Re-initialize data for differentiated function + ! Only reinitialize inout parameters - keep input-only parameters unchanged + + ! uplo already has correct value from original call + ! trans already has correct value from original call + ! diag already has correct value from original call + nsize = n + ! a already has correct value from original call + lda_val = lda ! LDA must be at least max( 1 + x = x_orig + incx_val = 1 ! INCX 1 + + ! Call the differentiated function + call strsv_d(uplo, trans, diag, nsize, a, a_d, lda_val, x, x_d, incx_val) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(4), parameter :: h = 1.0e-3 ! Step size for finite differences + real(4) :: relative_error, max_error + real(4) :: output_orig, output_pert + real(4) :: numerical_result, analytical_result + real(4) :: abs_error, abs_reference, error_bound + integer :: i, j + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3 + + ! Original values already stored in main program + + ! Central difference computation: f(x + h) - f(x - h) / (2h) + ! Forward perturbation: f(x + h) + a = a_orig + h * a_d_orig + x = x_orig + h * x_d_orig + call strsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + ! Store forward perturbation results + x_forward = x + + ! Backward perturbation: f(x - h) + a = a_orig - h * a_d_orig + x = x_orig - h * x_d_orig + call strsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + ! Store backward perturbation results + x_backward = x + + ! Compute central differences and compare with AD results + ! Check derivatives for output X + do i = 1, min(2, n) ! Check only first few elements + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (x_forward(i) - x_backward(i)) / (2.0e0 * h) + ! AD result + ad_result = x_d(i) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 2.0e-3 + 2.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) 'Large error in output X(', i, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_strsv diff --git a/BLAS/test/test_strsv_reverse.f90 b/BLAS/test/test_strsv_reverse.f90 new file mode 100644 index 0000000..1135fc0 --- /dev/null +++ b/BLAS/test/test_strsv_reverse.f90 @@ -0,0 +1,231 @@ +! Test program for STRSV reverse mode (adjoint) differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision +! Verification uses VJP methodology with finite differences + +program test_strsv_reverse + implicit none + + integer :: seed_array(33) + + external :: strsv + external :: strsv_b + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: uplo + character :: trans + character :: diag + integer :: nsize + real(4), dimension(max_size,max_size) :: a + integer :: lda_val + real(4), dimension(max_size) :: x + integer :: incx_val + + ! Adjoint variables (reverse mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + real(4), dimension(max_size,max_size) :: ab + real(4), dimension(max_size) :: xb + + ! Storage for original values (for VJP verification) + real(4), dimension(max_size,max_size) :: a_orig + real(4), dimension(max_size) :: x_orig + + ! Variables for VJP verification via finite differences + real(4), dimension(max_size) :: x_plus, x_minus + + ! Saved cotangents (output adjoints) for VJP verification + real(4), dimension(max_size) :: xb_orig + real(4), parameter :: h = 1.0e-3 + real(4) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + integer :: i, j + real(4), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + ! Initialize primal values + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + call random_number(a) + a = a * 2.0d0 - 1.0d0 + lda_val = lda + call random_number(x) + x = x * 2.0 - 1.0 + incx_val = 1 + + ! Store original primal values + a_orig = a + x_orig = x + + write(*,*) 'Testing STRSV' + + ! Initialize output adjoints (cotangents) with random values + ! These are the 'seeds' for reverse mode + call random_number(xb) + xb = xb * 2.0 - 1.0 + + ! Save output adjoints (cotangents) for VJP verification + ! Note: output adjoints may be modified by reverse mode function + xb_orig = xb + + ! Initialize input adjoints to zero (they will be computed) + ab = 0.0 + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! Differentiated code checks they are set via check_ISIZE*_initialized. + call set_ISIZE2OFA(max_size) + + ! Call reverse mode differentiated function + call strsv_b(uplo, trans, diag, nsize, a, ab, lda_val, x, xb, incx_val) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + ! For reverse mode, we verify: cotangent^T @ J @ direction = direction^T @ adjoint + ! Equivalently: cotangent^T @ (f(x+h*dir) - f(x-h*dir))/(2h) should equal dir^T @ computed_adjoint + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing (like tangents in forward mode) + real(4), dimension(max_size,max_size) :: a_dir + real(4), dimension(max_size) :: x_dir + + real(4), dimension(max_size) :: x_central_diff + + max_error = 0.0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Initialize random direction vectors for all inputs + call random_number(a_dir) + a_dir = a_dir * 2.0 - 1.0 + call random_number(x_dir) + x_dir = x_dir * 2.0 - 1.0 + + ! Forward perturbation: f(x + h*dir) + a = a_orig + h * a_dir + x = x_orig + h * x_dir + call strsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_plus = x + + ! Backward perturbation: f(x - h*dir) + a = a_orig - h * a_dir + x = x_orig - h * x_dir + call strsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_minus = x + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + x_central_diff = (x_plus - x_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0 + ! Compute and sort products for x (FD) + n_products = n + do i = 1, n + temp_products(i) = xb_orig(i) * x_central_diff(i) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0 + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = a_dir(i,j) * ab(i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for x + n_products = n + do i = 1, n + temp_products(i) = x_dir(i) * xb(i) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 2.0e-3 + 2.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + max_error = relative_error + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(4), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(4) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_strsv_reverse diff --git a/BLAS/test/test_strsv_vector_forward.f90 b/BLAS/test/test_strsv_vector_forward.f90 new file mode 100644 index 0000000..bdf3f61 --- /dev/null +++ b/BLAS/test/test_strsv_vector_forward.f90 @@ -0,0 +1,160 @@ +! Test program for STRSV vector forward mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision with nbdirsmax=4 + +program test_strsv_vector_forward + implicit none + include 'DIFFSIZES.inc' + + external :: strsv + external :: strsv_dv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, idir ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: uplo + character :: trans + character :: diag + integer :: nsize + real(4), dimension(max_size,max_size) :: a + integer :: lda_val + real(4), dimension(max_size) :: x + integer :: incx_val + + ! Vector mode derivative variables (type-promoted) + ! Scalars become arrays(nbdirsmax), arrays gain extra dimension + real(4), dimension(nbdirsmax,max_size,max_size) :: a_dv + real(4), dimension(nbdirsmax,max_size) :: x_dv + ! Declare variables for storing original values + real(4), dimension(max_size,max_size) :: a_orig + real(4), dimension(nbdirsmax,max_size,max_size) :: a_dv_orig + real(4), dimension(max_size) :: x_orig + real(4), dimension(nbdirsmax,max_size) :: x_dv_orig + + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize test parameters + nsize = n + lda_val = lda + incx_val = 1 + + ! Initialize test data with random numbers + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + uplo = 'U' + trans = 'N' + diag = 'N' + call random_number(a) + a = a * 2.0 - 1.0 ! Scale to [-1,1] + call random_number(x) + x = x * 2.0 - 1.0 ! Scale to [-1,1] + + ! Initialize input derivatives to random values (exactly like scalar mode) + do idir = 1, nbdirsmax + call random_number(a_dv(idir,:,:)) + a_dv(idir,:,:) = a_dv(idir,:,:) * 2.0 - 1.0 + end do + do idir = 1, nbdirsmax + call random_number(x_dv(idir,:)) + x_dv(idir,:) = x_dv(idir,:) * 2.0 - 1.0 + end do + + write(*,*) 'Testing STRSV (Vector Forward Mode)' + ! Store original values before any function calls (critical for INOUT parameters) + a_orig = a + a_dv_orig = a_dv + x_orig = x + x_dv_orig = x_dv + + ! Call the vector mode differentiated function + + call strsv_dv(uplo, trans, diag, nsize, a, a_dv, lda_val, x, x_dv, incx_val, nbdirsmax) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Vector forward mode test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(4), parameter :: h = 1.0e-3 ! Step size for finite differences + real(4) :: relative_error, max_error + real(4) :: abs_error, abs_reference, error_bound + real(4) :: central_diff, ad_result + integer :: i, j, idir + logical :: has_large_errors + real(4), dimension(max_size) :: x_forward, x_backward + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + write(*,*) 'Number of directions:', nbdirsmax + + ! Test each derivative direction separately + do idir = 1, nbdirsmax + + ! Forward perturbation: f(x + h * direction) + a = a_orig + h * a_dv_orig(idir,:,:) + x = x_orig + h * x_dv_orig(idir,:) + call strsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_forward = x + + ! Backward perturbation: f(x - h * direction) + a = a_orig - h * a_dv_orig(idir,:,:) + x = x_orig - h * x_dv_orig(idir,:) + call strsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_backward = x + + ! Compute central differences and compare with AD results + do i = 1, min(2, nsize) ! Check only first few elements + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (x_forward(i) - x_backward(i)) / (2.0e0 * h) + ! AD result + ad_result = x_dv(idir,i) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 2.0e-3 + 2.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) ' Large error in direction', idir, ' output X(', i, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_strsv_vector_forward \ No newline at end of file diff --git a/BLAS/test/test_strsv_vector_reverse.f90 b/BLAS/test/test_strsv_vector_reverse.f90 new file mode 100644 index 0000000..4915a0b --- /dev/null +++ b/BLAS/test/test_strsv_vector_reverse.f90 @@ -0,0 +1,235 @@ +! Test program for STRSV vector reverse mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision with nbdirsmax=4 + +program test_strsv_vector_reverse + implicit none + include 'DIFFSIZES.inc' + + external :: strsv + external :: strsv_bv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, k ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: uplo + character :: trans + character :: diag + integer :: nsize + real(4), dimension(max_size,max_size) :: a + integer :: lda_val + real(4), dimension(max_size) :: x + integer :: incx_val + + ! Adjoint variables (reverse vector mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + real(4), dimension(nbdirsmax,max_size,max_size) :: ab + real(4), dimension(nbdirsmax,max_size) :: xb + + ! Storage for original cotangents (for INOUT parameters in VJP verification) + real(4), dimension(nbdirsmax,max_size) :: xb_orig + + ! Storage for original values (for VJP verification) + real(4), dimension(max_size,max_size) :: a_orig + real(4), dimension(max_size) :: x_orig + + ! Variables for VJP verification via finite differences + real(4), parameter :: h = 1.0e-3 + real(4) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + real(4), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize primal values + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + call random_number(a) + a = a * 2.0 - 1.0 + lda_val = lda + call random_number(x) + x = x * 2.0 - 1.0 + incx_val = 1 + + ! Store original primal values + a_orig = a + x_orig = x + + ! Initialize output adjoints (cotangents) with random values for each direction + ! These are the 'seeds' for reverse mode + do k = 1, nbdirsmax + call random_number(xb(k,:)) + xb(k,:) = xb(k,:) * 2.0 - 1.0 + end do + + ! Initialize input adjoints to zero (they will be computed) + ! Note: Inout parameters are skipped - they already have output adjoints initialized + ab = 0.0 + + ! Save original cotangent seeds for OUTPUT/INOUT parameters (before function call) + xb_orig = xb + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! ISIZE1OF* (vectors): use n to match adjoint array size; ISIZE2OF* (matrices): use max_size. + call set_ISIZE2OFA(max_size) + + ! Call reverse vector mode differentiated function + call strsv_bv(uplo, trans, diag, nsize, a, ab, lda_val, x, xb, incx_val, nbdirsmax) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing + real(4), dimension(max_size,max_size) :: a_dir + real(4), dimension(max_size) :: x_dir + real(4), dimension(max_size) :: x_plus, x_minus, x_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Test each differentiation direction separately + do k = 1, nbdirsmax + + ! Initialize random direction vectors for all inputs + call random_number(a_dir) + a_dir = a_dir * 2.0 - 1.0 + call random_number(x_dir) + x_dir = x_dir * 2.0 - 1.0 + + ! Forward perturbation: f(x + h*dir) + a = a_orig + h * a_dir + x = x_orig + h * x_dir + call strsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_plus = x + + ! Backward perturbation: f(x - h*dir) + a = a_orig - h * a_dir + x = x_orig - h * x_dir + call strsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_minus = x + + ! Compute central differences and VJP verification + ! VJP check: direction^T @ adjoint should equal finite difference + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + x_central_diff = (x_plus - x_minus) / (2.0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0 + ! Compute and sort products for x (FD) + n_products = n + do i = 1, n + temp_products(i) = xb_orig(k,i) * x_central_diff(i) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0 + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = a_dir(i,j) * ab(k,i,j) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for x + n_products = n + do i = 1, n + temp_products(i) = x_dir(i) * xb(k,i) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 2.0e-3 + 2.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + ! Compute relative error for reporting + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + if (relative_error > max_error) max_error = relative_error + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=2.0e-3, atol=2.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(4), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(4) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_strsv_vector_reverse \ No newline at end of file From ddc1cac356a8482e0fefbe7d2104d62b04681a41 Mon Sep 17 00:00:00 2001 From: Shreyas911 Date: Sun, 23 Aug 2026 18:04:09 -0500 Subject: [PATCH 5/6] ctrsv, ztrsv, ctrsm, ztrsm correctly differentiated using Giles Method for all 4 modes. --- BLAS/src/ctrsm_b.f | 1066 +++++++++++++++++++ BLAS/src/ctrsm_bv.f | 1248 +++++++++++++++++++++++ BLAS/src/ctrsm_d.f | 588 +++++++++++ BLAS/src/ctrsm_dv.f | 715 +++++++++++++ BLAS/src/ctrsv_b.f | 869 ++++++++++++++++ BLAS/src/ctrsv_bv.f | 1014 ++++++++++++++++++ BLAS/src/ctrsv_d.f | 498 +++++++++ BLAS/src/ctrsv_dv.f | 619 +++++++++++ BLAS/src/ztrsm_b.f | 1057 +++++++++++++++++++ BLAS/src/ztrsm_bv.f | 1244 ++++++++++++++++++++++ BLAS/src/ztrsm_d.f | 583 +++++++++++ BLAS/src/ztrsm_dv.f | 711 +++++++++++++ BLAS/src/ztrsv_b.f | 858 ++++++++++++++++ BLAS/src/ztrsv_bv.f | 1005 ++++++++++++++++++ BLAS/src/ztrsv_d.f | 494 +++++++++ BLAS/src/ztrsv_dv.f | 612 +++++++++++ BLAS/test/test_ctrsm.f90 | 223 ++++ BLAS/test/test_ctrsm_reverse.f90 | 287 ++++++ BLAS/test/test_ctrsm_vector_forward.f90 | 202 ++++ BLAS/test/test_ctrsm_vector_reverse.f90 | 285 ++++++ BLAS/test/test_ctrsv.f90 | 196 ++++ BLAS/test/test_ctrsv_reverse.f90 | 256 +++++ BLAS/test/test_ctrsv_vector_forward.f90 | 176 ++++ BLAS/test/test_ctrsv_vector_reverse.f90 | 254 +++++ BLAS/test/test_ztrsm.f90 | 223 ++++ BLAS/test/test_ztrsm_reverse.f90 | 287 ++++++ BLAS/test/test_ztrsm_vector_forward.f90 | 202 ++++ BLAS/test/test_ztrsm_vector_reverse.f90 | 285 ++++++ BLAS/test/test_ztrsv.f90 | 196 ++++ BLAS/test/test_ztrsv_reverse.f90 | 256 +++++ BLAS/test/test_ztrsv_vector_forward.f90 | 176 ++++ BLAS/test/test_ztrsv_vector_reverse.f90 | 254 +++++ 32 files changed, 16939 insertions(+) create mode 100644 BLAS/src/ctrsm_b.f create mode 100644 BLAS/src/ctrsm_bv.f create mode 100644 BLAS/src/ctrsm_d.f create mode 100644 BLAS/src/ctrsm_dv.f create mode 100644 BLAS/src/ctrsv_b.f create mode 100644 BLAS/src/ctrsv_bv.f create mode 100644 BLAS/src/ctrsv_d.f create mode 100644 BLAS/src/ctrsv_dv.f create mode 100644 BLAS/src/ztrsm_b.f create mode 100644 BLAS/src/ztrsm_bv.f create mode 100644 BLAS/src/ztrsm_d.f create mode 100644 BLAS/src/ztrsm_dv.f create mode 100644 BLAS/src/ztrsv_b.f create mode 100644 BLAS/src/ztrsv_bv.f create mode 100644 BLAS/src/ztrsv_d.f create mode 100644 BLAS/src/ztrsv_dv.f create mode 100644 BLAS/test/test_ctrsm.f90 create mode 100644 BLAS/test/test_ctrsm_reverse.f90 create mode 100644 BLAS/test/test_ctrsm_vector_forward.f90 create mode 100644 BLAS/test/test_ctrsm_vector_reverse.f90 create mode 100644 BLAS/test/test_ctrsv.f90 create mode 100644 BLAS/test/test_ctrsv_reverse.f90 create mode 100644 BLAS/test/test_ctrsv_vector_forward.f90 create mode 100644 BLAS/test/test_ctrsv_vector_reverse.f90 create mode 100644 BLAS/test/test_ztrsm.f90 create mode 100644 BLAS/test/test_ztrsm_reverse.f90 create mode 100644 BLAS/test/test_ztrsm_vector_forward.f90 create mode 100644 BLAS/test/test_ztrsm_vector_reverse.f90 create mode 100644 BLAS/test/test_ztrsv.f90 create mode 100644 BLAS/test/test_ztrsv_reverse.f90 create mode 100644 BLAS/test/test_ztrsv_vector_forward.f90 create mode 100644 BLAS/test/test_ztrsv_vector_reverse.f90 diff --git a/BLAS/src/ctrsm_b.f b/BLAS/src/ctrsm_b.f new file mode 100644 index 0000000..fcd6db4 --- /dev/null +++ b/BLAS/src/ctrsm_b.f @@ -0,0 +1,1066 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ctrsm in reverse (adjoint) mode: +C gradient of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:out a:out b:in-out +C> \brief \b CTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C COMPLEX ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C COMPLEX A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> CTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**H. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is COMPLEX +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is COMPLEX array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE CTRSM_B(side, uplo, transa, diag, m, n, alpha, alphab, +C + a, ab, lda, b, bb, ldb) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C COMPLEX alpha +C COMPLEX alphab +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX a(lda, *), b(ldb, *) +C COMPLEX ab(lda, *), bb(ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC CONJG, MAX +CC .. +CC .. Local Scalars .. +C COMPLEX temp +C COMPLEX tempb +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, noconj, nounit, upper +C INTEGER ISIZE2OFA +CC .. +CC .. Parameters .. +C COMPLEX zero +C PARAMETER (zero=(0.0e+0,0.0e+0)) +C INTEGER max1 +C INTEGER max2 +C COMPLEX temp0 +C COMPLEX tempb0 +C COMPLEX tmp +C COMPLEX tmpb +C COMPLEX tmp0 +C COMPLEX tmpb0 +C COMPLEX tmp1 +C COMPLEX tmpb1 +C COMPLEX tmp2 +C COMPLEX tmpb2 +C COMPLEX tmp3 +C COMPLEX tmpb3 +C COMPLEX tmp4 +C COMPLEX tmpb4 +C INTEGER ad_to +C INTEGER*4 branch +C INTEGER ad_from +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_to2 +C INTEGER ad_from2 +C INTEGER ad_to3 +C INTEGER ad_from3 +C INTEGER ii2 +C INTEGER ii1 +CC .. +CC +CC Test the input parameters. +CC +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C noconj = LSAME(transa, 'T') +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE IF (m .LT. 0) THEN +C CALL PUSHCONTROL3B(4) +C info = 5 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(6) +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) THEN +C CALL PUSHCONTROL3B(7) +C info = 11 +C ELSE +C CALL PUSHCONTROL3B(7) +C END IF +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (m .EQ. 0 .OR. n .EQ. 0) THEN +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=n,1,-1 +C DO i=m,1,-1 +C bb(i, j) = (0.0,0.0) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ELSE IF (lside) THEN +CC +CC Start the operations. +CC +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,k-1 +C tmp = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=1,m,1 +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tmpb = bb(i, j) +C bb(i, j) = tmpb +C bb(k, j) = bb(k, j) + CONJG(-a(i, k))*tmpb +C ab(i, k) = ab(i, k) + CONJG(-b(k, j))*tmpb +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPCOMPLEX8(b(k, j)) +C tempb0 = CONJG(1.0/a(k, k))*bb(k, j) +C bb(k, j) = tempb0 +C ab(k, k) = ab(k, k) + CONJG(-(b(k, j)/a(k, k)))* +C + tempb0 +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C alphab = alphab + CONJG(b(i, j))*bb(i, j) +C bb(i, j) = CONJG(alpha)*bb(i, j) +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from = k + 1 +C DO i=ad_from,m +C tmp0 = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp0 +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=m,1,-1 +C CALL POPINTEGER4(ad_from) +C DO i=m,ad_from,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tmpb0 = bb(i, j) +C bb(i, j) = tmpb0 +C bb(k, j) = bb(k, j) + CONJG(-a(i, k))*tmpb0 +C ab(i, k) = ab(i, k) + CONJG(-b(k, j))*tmpb0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPCOMPLEX8(b(k, j)) +C tempb0 = CONJG(1.0/a(k, k))*bb(k, j) +C bb(k, j) = tempb0 +C ab(k, k) = ab(k, k) + CONJG(-(b(k, j)/a(k, k)))* +C + tempb0 +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C alphab = alphab + CONJG(b(i, j))*bb(i, j) +C bb(i, j) = CONJG(alpha)*bb(i, j) +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B +CC or B := alpha*inv( A**H )*B. +CC +C DO j=1,n +C DO i=1,m +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=1,i-1 +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO k=1,i-1 +C temp = temp - CONJG(a(k, i))*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(i, i)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tempb = bb(i, j) +C bb(i, j) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C tempb0 = CONJG(1.0/a(i, i))*tempb +C tempb = tempb0 +C ab(i, i) = ab(i, i) + CONJG(-(temp/a(i, i)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to0) +C DO k=ad_to0,1,-1 +C ab(k, i) = ab(k, i) + CONJG(-b(k, j))*tempb +C bb(k, j) = bb(k, j) + CONJG(-a(k, i))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(i, i)) +C ab(i, i) = ab(i, i) + CONJG(CONJG(-(temp/temp0**2))* +C + tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to1) +C DO k=ad_to1,1,-1 +C ab(k, i) = ab(k, i) + CONJG(CONJG(-b(k, j))*tempb) +C bb(k, j) = bb(k, j) + CONJG(-CONJG(a(k, i)))*tempb +C ENDDO +C END IF +C alphab = alphab + CONJG(b(i, j))*tempb +C bb(i, j) = bb(i, j) + CONJG(alpha)*tempb +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C temp = alpha*b(i, j) +C IF (noconj) THEN +C ad_from0 = i + 1 +C DO k=ad_from0,m +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C ad_from1 = i + 1 +C DO k=ad_from1,m +C temp = temp - CONJG(a(k, i))*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(i, i)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=1,m,1 +C CALL POPCOMPLEX8(b(i, j)) +C tempb = bb(i, j) +C bb(i, j) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C tempb0 = CONJG(1.0/a(i, i))*tempb +C tempb = tempb0 +C ab(i, i) = ab(i, i) + CONJG(-(temp/a(i, i)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_from0) +C DO k=m,ad_from0,-1 +C ab(k, i) = ab(k, i) + CONJG(-b(k, j))*tempb +C bb(k, j) = bb(k, j) + CONJG(-a(k, i))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(i, i)) +C ab(i, i) = ab(i, i) + CONJG(CONJG(-(temp/temp0**2))* +C + tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_from1) +C DO k=m,ad_from1,-1 +C ab(k, i) = ab(k, i) + CONJG(CONJG(-b(k, j))*tempb) +C bb(k, j) = bb(k, j) + CONJG(-CONJG(a(k, i)))*tempb +C ENDDO +C END IF +C alphab = alphab + CONJG(b(i, j))*tempb +C bb(i, j) = bb(i, j) + CONJG(alpha)*tempb +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C tmp1 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp1 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tempb0 = CONJG(1.0/a(j, j))*bb(i, j) +C bb(i, j) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(b(i, j)/a(j, j)))*tempb0 +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to2) +C DO k=ad_to2,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tmpb1 = bb(i, j) +C bb(i, j) = tmpb1 +C ab(k, j) = ab(k, j) + CONJG(-b(i, k))*tmpb1 +C bb(i, k) = bb(i, k) + CONJG(-a(k, j))*tmpb1 +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C alphab = alphab + CONJG(b(i, j))*bb(i, j) +C bb(i, j) = CONJG(alpha)*bb(i, j) +C ENDDO +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C ad_from2 = j + 1 +C DO k=ad_from2,n +C DO i=1,m +C tmp2 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp2 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tempb0 = CONJG(1.0/a(j, j))*bb(i, j) +C bb(i, j) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(b(i, j)/a(j, j)))*tempb0 +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from2) +C DO k=n,ad_from2,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tmpb2 = bb(i, j) +C bb(i, j) = tmpb2 +C ab(k, j) = ab(k, j) + CONJG(-b(i, k))*tmpb2 +C bb(i, k) = bb(i, k) + CONJG(-a(k, j))*tmpb2 +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C alphab = alphab + CONJG(b(i, j))*bb(i, j) +C bb(i, j) = CONJG(alpha)*bb(i, j) +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ) +CC or B := alpha*B*inv( A**H ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL2B(2) +C ELSE +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = b(i, k)/CONJG(a(k, k)) +C ENDDO +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C CALL PUSHCONTROL2B(0) +C END IF +C DO j=1,k-1 +C IF (noconj) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = a(j, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCOMPLEX8(temp) +C temp = CONJG(a(j, k)) +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,m +C tmp3 = b(i, j) - temp*b(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp3 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(j - 1) +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO k=1,n,1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C alphab = alphab + CONJG(b(i, k))*bb(i, k) +C bb(i, k) = CONJG(alpha)*bb(i, k) +C ENDDO +C CALL POPINTEGER4(ad_to3) +C DO j=ad_to3,1,-1 +C tempb = (0.0,0.0) +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tmpb3 = bb(i, j) +C bb(i, j) = tmpb3 +C tempb = tempb + CONJG(-b(i, k))*tmpb3 +C bb(i, k) = bb(i, k) + CONJG(-temp)*tmpb3 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C ab(j, k) = ab(j, k) + CONJG(tempb) +C ELSE +C CALL POPCOMPLEX8(temp) +C ab(j, k) = ab(j, k) + tempb +C END IF +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .NE. 0) THEN +C IF (branch .EQ. 1) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C temp0 = CONJG(a(k, k)) +C ab(k, k) = ab(k, k) + CONJG(CONJG(-(b(i, k)/temp0**2)) +C + *bb(i, k)) +C bb(i, k) = CONJG(1.0/temp0)*bb(i, k) +C ENDDO +C ELSE +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C tempb0 = CONJG(1.0/a(k, k))*bb(i, k) +C bb(i, k) = tempb0 +C ab(k, k) = ab(k, k) + CONJG(-(b(i, k)/a(k, k)))*tempb0 +C ENDDO +C END IF +C END IF +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL2B(2) +C ELSE +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = b(i, k)/CONJG(a(k, k)) +C ENDDO +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C CALL PUSHCONTROL2B(0) +C END IF +C ad_from3 = k + 1 +C DO j=ad_from3,n +C IF (noconj) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = a(j, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCOMPLEX8(temp) +C temp = CONJG(a(j, k)) +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,m +C tmp4 = b(i, j) - temp*b(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp4 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from3) +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO k=n,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C alphab = alphab + CONJG(b(i, k))*bb(i, k) +C bb(i, k) = CONJG(alpha)*bb(i, k) +C ENDDO +C CALL POPINTEGER4(ad_from3) +C DO j=n,ad_from3,-1 +C tempb = (0.0,0.0) +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C tmpb4 = bb(i, j) +C bb(i, j) = tmpb4 +C tempb = tempb + CONJG(-b(i, k))*tmpb4 +C bb(i, k) = bb(i, k) + CONJG(-temp)*tmpb4 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C ab(j, k) = ab(j, k) + CONJG(tempb) +C ELSE +C CALL POPCOMPLEX8(temp) +C ab(j, k) = ab(j, k) + tempb +C END IF +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .NE. 0) THEN +C IF (branch .EQ. 1) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C temp0 = CONJG(a(k, k)) +C ab(k, k) = ab(k, k) + CONJG(CONJG(-(b(i, k)/temp0**2)) +C + *bb(i, k)) +C bb(i, k) = CONJG(1.0/temp0)*bb(i, k) +C ENDDO +C ELSE +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C tempb0 = CONJG(1.0/a(k, k))*bb(i, k) +C bb(i, k) = tempb0 +C ab(k, k) = ab(k, k) + CONJG(-(b(i, k)/a(k, k)))*tempb0 +C ENDDO +C END IF +C END IF +C ENDDO +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE CTRSM_B(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB) +! +! Reverse-mode (adjoint) derivative of CTRSM, black-box/Giles-style, +! Wirtinger/CR-calculus convention. ALPHA complex. +! Bb = CONJG(ALPHA)*Yb -- NOT alpha*Yb (see notes above). +! + IMPLICIT NONE + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + COMPLEX ALPHA, ALPHAB + COMPLEX A(LDA,*), AB(LDA,*) + COMPLEX B(LDB,*), BB(LDB,*) + + COMPLEX X(M,N), BLOC(M,N) + LOGICAL LEFT, UPPER, UNIT, ISN, IST, ISC + INTEGER I, J, K + INTRINSIC CONJG + + LEFT = (SIDE.EQ.'L' .OR. SIDE.EQ.'l') + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + ISN = (TRANSA.EQ.'N' .OR. TRANSA.EQ.'n') + IST = (TRANSA.EQ.'T' .OR. TRANSA.EQ.'t') + ISC = (TRANSA.EQ.'C' .OR. TRANSA.EQ.'c') + + IF (M.EQ.0 .OR. N.EQ.0) THEN + ALPHAB = (0.0E0,0.0E0) + RETURN + END IF + + DO J = 1, N + DO I = 1, M + BLOC(I,J) = B(I,J) + END DO + END DO + +C Solve M^H*Yb = Xb (SIDE='L') or Yb*M^H = Xb (SIDE='R'), overwrite BB + IF (ISN) THEN + CALL CTRSM(SIDE, UPLO, 'C', DIAG, M, N, (1.0E0,0.0E0), + + A, LDA, BB, LDB) + ELSE IF (ISC) THEN + CALL CTRSM(SIDE, UPLO, 'N', DIAG, M, N, (1.0E0,0.0E0), + + A, LDA, BB, LDB) + ELSE +C TRANSA='T': conj(A)*Yb=Xb <=> A*conj(Yb)=conj(Xb) (SIDE-agnostic trick) + DO J = 1, N + DO I = 1, M + BB(I,J) = CONJG(BB(I,J)) + END DO + END DO + CALL CTRSM(SIDE, UPLO, 'N', DIAG, M, N, (1.0E0,0.0E0), + + A, LDA, BB, LDB) + DO J = 1, N + DO I = 1, M + BB(I,J) = CONJG(BB(I,J)) + END DO + END DO + END IF + + DO J = 1, N + DO I = 1, M + X(I,J) = BLOC(I,J) + END DO + END DO + CALL CTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + +C alphab = sum Yb .* conj(B) (ORIGINAL B, not X) + ALPHAB = (0.0E0,0.0E0) + DO J = 1, N + DO I = 1, M + ALPHAB = ALPHAB + BB(I,J)*CONJG(BLOC(I,J)) + END DO + END DO + + DO J = 1, LDA + DO I = 1, LDA + AB(I,J) = (0.0E0,0.0E0) + END DO + END DO + + IF (LEFT) THEN + DO J = 1, M + DO I = 1, M + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + DO K = 1, N + AB(I,J) = AB(I,J) - BB(I,K)*CONJG(X(J,K)) + END DO + ELSE IF (IST) THEN + DO K = 1, N + AB(I,J) = AB(I,J) - CONJG(X(I,K))*BB(J,K) + END DO + ELSE + DO K = 1, N + AB(I,J) = AB(I,J) - CONJG(BB(J,K))*X(I,K) + END DO + END IF + END IF + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + DO K = 1, M + AB(I,J) = AB(I,J) - CONJG(X(K,I))*BB(K,J) + END DO + ELSE IF (IST) THEN + DO K = 1, M + AB(I,J) = AB(I,J) - CONJG(X(K,J))*BB(K,I) + END DO + ELSE + DO K = 1, M + AB(I,J) = AB(I,J) - X(K,J)*CONJG(BB(K,I)) + END DO + END IF + END IF + END IF + END DO + END DO + END IF + +C Bb = CONJG(alpha) * Yb (BB currently holds Yb) + DO J = 1, N + DO I = 1, M + BB(I,J) = CONJG(ALPHA)*BB(I,J) + END DO + END DO + + RETURN + END SUBROUTINE CTRSM_B + diff --git a/BLAS/src/ctrsm_bv.f b/BLAS/src/ctrsm_bv.f new file mode 100644 index 0000000..de41aca --- /dev/null +++ b/BLAS/src/ctrsm_bv.f @@ -0,0 +1,1248 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ctrsm in reverse (adjoint) mode (with options multiDirectional): +C gradient of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:out a:out b:in-out +C> \brief \b CTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C COMPLEX ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C COMPLEX A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> CTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**H. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is COMPLEX +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is COMPLEX array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE CTRSM_BV(side, uplo, transa, diag, m, n, alpha, alphab +C + , a, ab, lda, b, bb, ldb, nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C COMPLEX alpha +C COMPLEX alphab(nbdirsmax) +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX a(lda, *), b(ldb, *) +C COMPLEX ab(nbdirsmax, lda, *), bb(nbdirsmax, ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC CONJG, MAX +CC .. +CC .. Local Scalars .. +C COMPLEX temp +C COMPLEX tempb(nbdirsmax) +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, noconj, nounit, upper +C INTEGER ISIZE2OFA +CC .. +CC .. Parameters .. +C COMPLEX zero +C PARAMETER (zero=(0.0e+0,0.0e+0)) +C INTEGER max1 +C INTEGER max2 +C INTEGER nd +C COMPLEX temp0 +C COMPLEX tempb0(nbdirsmax) +C COMPLEX tmp +C COMPLEX tmpb(nbdirsmax) +C COMPLEX tmp0 +C COMPLEX tmpb0(nbdirsmax) +C COMPLEX tmp1 +C COMPLEX tmpb1(nbdirsmax) +C COMPLEX tmp2 +C COMPLEX tmpb2(nbdirsmax) +C COMPLEX tmp3 +C COMPLEX tmpb3(nbdirsmax) +C COMPLEX tmp4 +C COMPLEX tmpb4(nbdirsmax) +C INTEGER ad_to +C INTEGER*4 branch +C INTEGER ad_from +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_to2 +C INTEGER ad_from2 +C INTEGER ad_to3 +C INTEGER ad_from3 +C INTEGER ii2 +C INTEGER ii1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C noconj = LSAME(transa, 'T') +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE IF (m .LT. 0) THEN +C CALL PUSHCONTROL3B(4) +C info = 5 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(6) +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) THEN +C CALL PUSHCONTROL3B(7) +C info = 11 +C ELSE +C CALL PUSHCONTROL3B(7) +C END IF +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (m .EQ. 0 .OR. n .EQ. 0) THEN +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=n,1,-1 +C DO i=m,1,-1 +C DO nd=1,nbdirs +C bb(nd, i, j) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C ELSE IF (lside) THEN +CC +CC Start the operations. +CC +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,k-1 +C tmp = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=1,m,1 +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tmpb(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb(nd) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-a(i, k))*tmpb +C + (nd) +C ab(nd, i, k) = ab(nd, i, k) + CONJG(-b(k, j))*tmpb +C + (nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPCOMPLEX8(b(k, j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(k, k))*bb(nd, k, j) +C bb(nd, k, j) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) + CONJG(-(b(k, j)/a(k +C + , k)))*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*bb(nd, i, j +C + ) +C bb(nd, i, j) = CONJG(alpha)*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from = k + 1 +C DO i=ad_from,m +C tmp0 = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp0 +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=m,1,-1 +C CALL POPINTEGER4(ad_from) +C DO i=m,ad_from,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tmpb0(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb0(nd) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-a(i, k))* +C + tmpb0(nd) +C ab(nd, i, k) = ab(nd, i, k) + CONJG(-b(k, j))* +C + tmpb0(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPCOMPLEX8(b(k, j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(k, k))*bb(nd, k, j) +C bb(nd, k, j) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) + CONJG(-(b(k, j)/a(k +C + , k)))*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*bb(nd, i, j +C + ) +C bb(nd, i, j) = CONJG(alpha)*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B +CC or B := alpha*inv( A**H )*B. +CC +C DO j=1,n +C DO i=1,m +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=1,i-1 +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO k=1,i-1 +C temp = temp - CONJG(a(k, i))*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(i, i)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tempb(nd) = bb(nd, i, j) +C bb(nd, i, j) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, i, i) = ab(nd, i, i) + CONJG(-(temp/a(i, i) +C + ))*tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to0) +C DO k=ad_to0,1,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) + CONJG(-b(k, j))* +C + tempb(nd) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-a(k, i))* +C + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(i, i)) +C DO nd=1,nbdirs +C ab(nd, i, i) = ab(nd, i, i) + CONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO k=ad_to1,1,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) + CONJG(CONJG(-b(k, j) +C + )*tempb(nd)) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-CONJG(a(k, i) +C + ))*tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*tempb(nd) +C bb(nd, i, j) = bb(nd, i, j) + CONJG(alpha)*tempb(nd) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C temp = alpha*b(i, j) +C IF (noconj) THEN +C ad_from0 = i + 1 +C DO k=ad_from0,m +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C ad_from1 = i + 1 +C DO k=ad_from1,m +C temp = temp - CONJG(a(k, i))*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(i, i)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=1,m,1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tempb(nd) = bb(nd, i, j) +C bb(nd, i, j) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, i, i) = ab(nd, i, i) + CONJG(-(temp/a(i, i) +C + ))*tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from0) +C DO k=m,ad_from0,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) + CONJG(-b(k, j))* +C + tempb(nd) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-a(k, i))* +C + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(i, i)) +C DO nd=1,nbdirs +C ab(nd, i, i) = ab(nd, i, i) + CONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from1) +C DO k=m,ad_from1,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) + CONJG(CONJG(-b(k, j) +C + )*tempb(nd)) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-CONJG(a(k, i) +C + ))*tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*tempb(nd) +C bb(nd, i, j) = bb(nd, i, j) + CONJG(alpha)*tempb(nd) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C tmp1 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp1 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*bb(nd, i, j) +C bb(nd, i, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(b(i, j)/a(j, j +C + )))*tempb0(nd) +C ENDDO +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to2) +C DO k=ad_to2,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tmpb1(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb1(nd) +C ab(nd, k, j) = ab(nd, k, j) + CONJG(-b(i, k))*tmpb1( +C + nd) +C bb(nd, i, k) = bb(nd, i, k) + CONJG(-a(k, j))*tmpb1( +C + nd) +C ENDDO +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*bb(nd, i, j) +C bb(nd, i, j) = CONJG(alpha)*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C ad_from2 = j + 1 +C DO k=ad_from2,n +C DO i=1,m +C tmp2 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp2 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*bb(nd, i, j) +C bb(nd, i, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(b(i, j)/a(j, j +C + )))*tempb0(nd) +C ENDDO +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from2) +C DO k=n,ad_from2,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tmpb2(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb2(nd) +C ab(nd, k, j) = ab(nd, k, j) + CONJG(-b(i, k))*tmpb2( +C + nd) +C bb(nd, i, k) = bb(nd, i, k) + CONJG(-a(k, j))*tmpb2( +C + nd) +C ENDDO +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*bb(nd, i, j) +C bb(nd, i, j) = CONJG(alpha)*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ) +CC or B := alpha*B*inv( A**H ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL2B(2) +C ELSE +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = b(i, k)/CONJG(a(k, k)) +C ENDDO +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C CALL PUSHCONTROL2B(0) +C END IF +C DO j=1,k-1 +C IF (noconj) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = a(j, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCOMPLEX8(temp) +C temp = CONJG(a(j, k)) +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,m +C tmp3 = b(i, j) - temp*b(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp3 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(j - 1) +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO k=1,n,1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, k))*bb(nd, i, k) +C bb(nd, i, k) = CONJG(alpha)*bb(nd, i, k) +C ENDDO +C ENDDO +C CALL POPINTEGER4(ad_to3) +C DO j=ad_to3,1,-1 +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tmpb3(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb3(nd) +C tempb(nd) = tempb(nd) + CONJG(-b(i, k))*tmpb3(nd) +C bb(nd, i, k) = bb(nd, i, k) + CONJG(-temp)*tmpb3(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C ab(nd, j, k) = ab(nd, j, k) + CONJG(tempb(nd)) +C ENDDO +C ELSE +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C ab(nd, j, k) = ab(nd, j, k) + tempb(nd) +C ENDDO +C END IF +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .NE. 0) THEN +C IF (branch .EQ. 1) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C temp0 = CONJG(a(k, k)) +C DO nd=1,nbdirs +C ab(nd, k, k) = ab(nd, k, k) + CONJG(CONJG(-(b(i, k)/ +C + temp0**2))*bb(nd, i, k)) +C bb(nd, i, k) = CONJG(1.0/temp0)*bb(nd, i, k) +C ENDDO +C ENDDO +C ELSE +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(k, k))*bb(nd, i, k) +C bb(nd, i, k) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) + CONJG(-(b(i, k)/a(k, k +C + )))*tempb0(nd) +C ENDDO +C ENDDO +C END IF +C END IF +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL2B(2) +C ELSE +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = b(i, k)/CONJG(a(k, k)) +C ENDDO +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C CALL PUSHCONTROL2B(0) +C END IF +C ad_from3 = k + 1 +C DO j=ad_from3,n +C IF (noconj) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = a(j, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCOMPLEX8(temp) +C temp = CONJG(a(j, k)) +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,m +C tmp4 = b(i, j) - temp*b(i, k) +C CALL PUSHCOMPLEX8(b(i, j)) +C b(i, j) = tmp4 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from3) +C DO i=1,m +C CALL PUSHCOMPLEX8(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO k=n,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, k))*bb(nd, i, k) +C bb(nd, i, k) = CONJG(alpha)*bb(nd, i, k) +C ENDDO +C ENDDO +C CALL POPINTEGER4(ad_from3) +C DO j=n,ad_from3,-1 +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, j)) +C DO nd=1,nbdirs +C tmpb4(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb4(nd) +C tempb(nd) = tempb(nd) + CONJG(-b(i, k))*tmpb4(nd) +C bb(nd, i, k) = bb(nd, i, k) + CONJG(-temp)*tmpb4(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C ab(nd, j, k) = ab(nd, j, k) + CONJG(tempb(nd)) +C ENDDO +C ELSE +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C ab(nd, j, k) = ab(nd, j, k) + tempb(nd) +C ENDDO +C END IF +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .NE. 0) THEN +C IF (branch .EQ. 1) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C temp0 = CONJG(a(k, k)) +C DO nd=1,nbdirs +C ab(nd, k, k) = ab(nd, k, k) + CONJG(CONJG(-(b(i, k)/ +C + temp0**2))*bb(nd, i, k)) +C bb(nd, i, k) = CONJG(1.0/temp0)*bb(nd, i, k) +C ENDDO +C ENDDO +C ELSE +C DO i=m,1,-1 +C CALL POPCOMPLEX8(b(i, k)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(k, k))*bb(nd, i, k) +C bb(nd, i, k) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) + CONJG(-(b(i, k)/a(k, k +C + )))*tempb0(nd) +C ENDDO +C ENDDO +C END IF +C END IF +C ENDDO +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE CTRSM_BV(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB, NBDIRS) +! +! Vector reverse-mode (adjoint) derivative of CTRSM, black-box/Giles-style. +! Self-contained -- does not call CTRSM_B. +! + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB, NBDIRS + COMPLEX ALPHA + COMPLEX ALPHAB(NBDIRSMAX) + COMPLEX A(LDA,*), AB(NBDIRSMAX,LDA,*) + COMPLEX B(LDB,*), BB(NBDIRSMAX,LDB,*) + + COMPLEX X(M,N), BLOC(M,N) + COMPLEX AB_SLICE(LDA,LDA), BB_SLICE(LDB,N) + LOGICAL LEFT, UPPER, UNIT, ISN, IST, ISC + INTEGER ND, I, J, K + INTRINSIC CONJG + + LEFT = (SIDE.EQ.'L' .OR. SIDE.EQ.'l') + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + ISN = (TRANSA.EQ.'N' .OR. TRANSA.EQ.'n') + IST = (TRANSA.EQ.'T' .OR. TRANSA.EQ.'t') + ISC = (TRANSA.EQ.'C' .OR. TRANSA.EQ.'c') + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (M.EQ.0 .OR. N.EQ.0) THEN + DO ND = 1, NBDIRS + ALPHAB(ND) = (0.0E0,0.0E0) + END DO + RETURN + END IF + + DO J = 1, N + DO I = 1, M + BLOC(I,J) = B(I,J) + END DO + END DO + DO J = 1, N + DO I = 1, M + X(I,J) = BLOC(I,J) + END DO + END DO + CALL CTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO ND = 1, NBDIRS + + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = BB(ND,I,J) + END DO + END DO + + IF (ISN) THEN + CALL CTRSM(SIDE, UPLO, 'C', DIAG, M, N, (1.0E0,0.0E0), + + A, LDA, BB_SLICE, LDB) + ELSE IF (ISC) THEN + CALL CTRSM(SIDE, UPLO, 'N', DIAG, M, N, (1.0E0,0.0E0), + + A, LDA, BB_SLICE, LDB) + ELSE + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = CONJG(BB_SLICE(I,J)) + END DO + END DO + CALL CTRSM(SIDE, UPLO, 'N', DIAG, M, N, (1.0E0,0.0E0), + + A, LDA, BB_SLICE, LDB) + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = CONJG(BB_SLICE(I,J)) + END DO + END DO + END IF + + ALPHAB(ND) = (0.0E0,0.0E0) + DO J = 1, N + DO I = 1, M + ALPHAB(ND) = ALPHAB(ND) + BB_SLICE(I,J)*CONJG(BLOC(I,J)) + END DO + END DO + + DO J = 1, LDA + DO I = 1, LDA + AB_SLICE(I,J) = (0.0E0,0.0E0) + END DO + END DO + + IF (LEFT) THEN + DO J = 1, M + DO I = 1, M + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - BB_SLICE(I,K)*CONJG(X(J,K)) + END DO + ELSE IF (IST) THEN + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - CONJG(X(I,K))*BB_SLICE(J,K) + END DO + ELSE + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - CONJG(BB_SLICE(J,K))*X(I,K) + END DO + END IF + END IF + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - CONJG(X(K,I))*BB_SLICE(K,J) + END DO + ELSE IF (IST) THEN + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - CONJG(X(K,J))*BB_SLICE(K,I) + END DO + ELSE + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - X(K,J)*CONJG(BB_SLICE(K,I)) + END DO + END IF + END IF + END IF + END DO + END DO + END IF + + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = CONJG(ALPHA)*BB_SLICE(I,J) + END DO + END DO + + DO J = 1, N + DO I = 1, M + BB(ND,I,J) = BB_SLICE(I,J) + END DO + END DO + DO J = 1, LDA + DO I = 1, LDA + AB(ND,I,J) = AB_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE CTRSM_BV + diff --git a/BLAS/src/ctrsm_d.f b/BLAS/src/ctrsm_d.f new file mode 100644 index 0000000..df567f5 --- /dev/null +++ b/BLAS/src/ctrsm_d.f @@ -0,0 +1,588 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ctrsm in forward (tangent) mode: +C variations of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:in a:in b:in-out +C> \brief \b CTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C COMPLEX ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C COMPLEX A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> CTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**H. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is COMPLEX +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is COMPLEX array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE CTRSM_D(side, uplo, transa, diag, m, n, alpha, alphad, +C + a, ad, lda, b, bd, ldb) +C IMPLICIT NONE +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C COMPLEX alpha +C COMPLEX alphad +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX a(lda, *), b(ldb, *) +C COMPLEX ad(lda, *), bd(ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC CONJG, MAX +CC .. +CC .. Local Scalars .. +C COMPLEX temp +C COMPLEX tempd +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, noconj, nounit, upper +CC .. +CC .. Parameters .. +C COMPLEX zero +C PARAMETER (zero=(0.0e+0,0.0e+0)) +C INTEGER max1 +C INTEGER max2 +C COMPLEX temp0 +C COMPLEX temp1 +CC .. +CC +CC Test the input parameters. +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C noconj = LSAME(transa, 'T') +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 4 +C ELSE IF (m .LT. 0) THEN +C info = 5 +C ELSE IF (n .LT. 0) THEN +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) info = 11 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('CTRSM ', info) +C RETURN +C ELSE IF (m .EQ. 0 .OR. n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=1,n +C DO i=1,m +C bd(i, j) = (0.0,0.0) +C b(i, j) = zero +C ENDDO +C ENDDO +C RETURN +C ELSE +CC +CC Start the operations. +CC +C IF (lside) THEN +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C bd(k, j) = (bd(k, j)-temp0*ad(k, k))/a(k, k) +C b(k, j) = temp0 +C END IF +C DO i=1,k-1 +C bd(i, j) = bd(i, j) - a(i, k)*bd(k, j) - b(k, j)*ad( +C + i, k) +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C bd(k, j) = (bd(k, j)-temp0*ad(k, k))/a(k, k) +C b(k, j) = temp0 +C END IF +C DO i=k+1,m +C bd(i, j) = bd(i, j) - a(i, k)*bd(k, j) - b(k, j)*ad( +C + i, k) +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B +CC or B := alpha*inv( A**H )*B. +CC +C DO j=1,n +C DO i=1,m +C tempd = b(i, j)*alphad + alpha*bd(i, j) +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=1,i-1 +C tempd = tempd - b(k, j)*ad(k, i) - a(k, i)*bd(k, j) +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C tempd = (tempd-temp0*ad(i, i))/a(i, i) +C temp = temp0 +C END IF +C ELSE +C DO k=1,i-1 +C temp0 = CONJG(a(k, i)) +C tempd = tempd - b(k, j)*CONJG(ad(k, i)) - temp0*bd(k +C + , j) +C temp = temp - temp0*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(i, i)) +C tempd = (tempd-temp*CONJG(ad(i, i))/temp0)/temp0 +C temp = temp/temp0 +C END IF +C END IF +C bd(i, j) = tempd +C b(i, j) = temp +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C tempd = b(i, j)*alphad + alpha*bd(i, j) +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=i+1,m +C tempd = tempd - b(k, j)*ad(k, i) - a(k, i)*bd(k, j) +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C tempd = (tempd-temp0*ad(i, i))/a(i, i) +C temp = temp0 +C END IF +C ELSE +C DO k=i+1,m +C temp0 = CONJG(a(k, i)) +C tempd = tempd - b(k, j)*CONJG(ad(k, i)) - temp0*bd(k +C + , j) +C temp = temp - temp0*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(i, i)) +C tempd = (tempd-temp*CONJG(ad(i, i))/temp0)/temp0 +C temp = temp/temp0 +C END IF +C END IF +C bd(i, j) = tempd +C b(i, j) = temp +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(k, j) - a(k, j)*bd(i +C + , k) +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C bd(i, j) = (bd(i, j)-temp0*ad(j, j))/a(j, j) +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=j+1,n +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(k, j) - a(k, j)*bd(i +C + , k) +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C bd(i, j) = (bd(i, j)-temp0*ad(j, j))/a(j, j) +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ) +CC or B := alpha*B*inv( A**H ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C bd(i, k) = (bd(i, k)-temp0*ad(k, k))/a(k, k) +C b(i, k) = temp0 +C ENDDO +C ELSE +C DO i=1,m +C temp0 = CONJG(a(k, k)) +C temp1 = b(i, k)/temp0 +C bd(i, k) = (bd(i, k)-temp1*CONJG(ad(k, k)))/temp0 +C b(i, k) = temp1 +C ENDDO +C END IF +C END IF +C DO j=1,k-1 +C IF (noconj) THEN +C tempd = ad(j, k) +C temp = a(j, k) +C ELSE +C tempd = CONJG(ad(j, k)) +C temp = CONJG(a(j, k)) +C END IF +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*tempd - temp*bd(i, k) +C b(i, j) = b(i, j) - temp*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C bd(i, k) = b(i, k)*alphad + alpha*bd(i, k) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C temp1 = b(i, k)/a(k, k) +C bd(i, k) = (bd(i, k)-temp1*ad(k, k))/a(k, k) +C b(i, k) = temp1 +C ENDDO +C ELSE +C DO i=1,m +C temp1 = CONJG(a(k, k)) +C temp0 = b(i, k)/temp1 +C bd(i, k) = (bd(i, k)-temp0*CONJG(ad(k, k)))/temp1 +C b(i, k) = temp0 +C ENDDO +C END IF +C END IF +C DO j=k+1,n +C IF (noconj) THEN +C tempd = ad(j, k) +C temp = a(j, k) +C ELSE +C tempd = CONJG(ad(j, k)) +C temp = CONJG(a(j, k)) +C END IF +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*tempd - temp*bd(i, k) +C b(i, j) = b(i, j) - temp*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C bd(i, k) = b(i, k)*alphad + alpha*bd(i, k) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C END IF +CC +C RETURN +CC +CC End of CTRSM +CC +C END IF +C END + + SUBROUTINE CTRSM_D(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB) +! +! Forward-mode derivative of CTRSM, black-box/Giles-style. ALPHA complex. +! Passing the SAME transa flag to CTRMM/CTRSM as the primal call handles +! TRANSA='C' conjugation automatically. +! + IMPLICIT NONE + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + COMPLEX ALPHA, ALPHAD + COMPLEX A(LDA,*), AD(LDA,*) + COMPLEX B(LDB,*), BD(LDB,*) + + COMPLEX X(M,N), T(M,N) + INTEGER I, J + + IF (M.EQ.0 .OR. N.EQ.0) RETURN + + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL CTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO J = 1, N + DO I = 1, M + T(I,J) = X(I,J) + END DO + END DO + CALL CTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, (1.0E0,0.0E0), + + AD, LDA, T, M) + + DO J = 1, N + DO I = 1, M + BD(I,J) = ALPHAD*B(I,J) + ALPHA*BD(I,J) - T(I,J) + END DO + END DO + + CALL CTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, (1.0E0,0.0E0), + + A, LDA, BD, LDB) + + RETURN + END SUBROUTINE CTRSM_D + diff --git a/BLAS/src/ctrsm_dv.f b/BLAS/src/ctrsm_dv.f new file mode 100644 index 0000000..14f34b4 --- /dev/null +++ b/BLAS/src/ctrsm_dv.f @@ -0,0 +1,715 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ctrsm in forward (tangent) mode (with options multiDirectional): +C variations of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:in a:in b:in-out +C> \brief \b CTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C COMPLEX ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C COMPLEX A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> CTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**H. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is COMPLEX +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is COMPLEX array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE CTRSM_DV(side, uplo, transa, diag, m, n, alpha, alphad +C + , a, ad, lda, b, bd, ldb, nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C COMPLEX alpha +C COMPLEX alphad(nbdirsmax) +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX a(lda, *), b(ldb, *) +C COMPLEX ad(nbdirsmax, lda, *), bd(nbdirsmax, ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC CONJG, MAX +CC .. +CC .. Local Scalars .. +C COMPLEX temp +C COMPLEX tempd(nbdirsmax) +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, noconj, nounit, upper +CC .. +CC .. Parameters .. +C COMPLEX zero +C PARAMETER (zero=(0.0e+0,0.0e+0)) +C INTEGER max1 +C INTEGER max2 +C INTEGER nd +C COMPLEX temp0 +C COMPLEX temp1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C noconj = LSAME(transa, 'T') +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 4 +C ELSE IF (m .LT. 0) THEN +C info = 5 +C ELSE IF (n .LT. 0) THEN +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) info = 11 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('CTRSM ', info) +C RETURN +C ELSE IF (m .EQ. 0 .OR. n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = (0.0,0.0) +C ENDDO +C b(i, j) = zero +C ENDDO +C ENDDO +C RETURN +C ELSE +CC +CC Start the operations. +CC +C IF (lside) THEN +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, +C + j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, k, j) = (bd(nd, k, j)-temp0*ad(nd, k, k))/a +C + (k, k) +C ENDDO +C b(k, j) = temp0 +C END IF +C DO i=1,k-1 +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - a(i, k)*bd(nd, k, j) +C + - b(k, j)*ad(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, +C + j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, k, j) = (bd(nd, k, j)-temp0*ad(nd, k, k))/a +C + (k, k) +C ENDDO +C b(k, j) = temp0 +C END IF +C DO i=k+1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - a(i, k)*bd(nd, k, j) +C + - b(k, j)*ad(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B +CC or B := alpha*inv( A**H )*B. +CC +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C tempd(nd) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=1,i-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*ad(nd, k, i) - a(k +C + , i)*bd(nd, k, j) +C ENDDO +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, i, i))/a(i, i) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO k=1,i-1 +C temp0 = CONJG(a(k, i)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*CONJG(ad(nd, k, i) +C + ) - temp0*bd(nd, k, j) +C ENDDO +C temp = temp - temp0*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(i, i)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*CONJG(ad(nd, i, i))/ +C + temp0)/temp0 +C ENDDO +C temp = temp/temp0 +C END IF +C END IF +C DO nd=1,nbdirs +C bd(nd, i, j) = tempd(nd) +C ENDDO +C b(i, j) = temp +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=i+1,m +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*ad(nd, k, i) - a(k +C + , i)*bd(nd, k, j) +C ENDDO +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, i, i))/a(i, i) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO k=i+1,m +C temp0 = CONJG(a(k, i)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*CONJG(ad(nd, k, i) +C + ) - temp0*bd(nd, k, j) +C ENDDO +C temp = temp - temp0*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(i, i)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*CONJG(ad(nd, i, i))/ +C + temp0)/temp0 +C ENDDO +C temp = temp/temp0 +C END IF +C END IF +C DO nd=1,nbdirs +C bd(nd, i, j) = tempd(nd) +C ENDDO +C b(i, j) = temp +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, k, j) - +C + a(k, j)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C DO nd=1,nbdirs +C bd(nd, i, j) = (bd(nd, i, j)-temp0*ad(nd, j, j))/a(j +C + , j) +C ENDDO +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=j+1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, k, j) - +C + a(k, j)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C DO nd=1,nbdirs +C bd(nd, i, j) = (bd(nd, i, j)-temp0*ad(nd, j, j))/a(j +C + , j) +C ENDDO +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ) +CC or B := alpha*B*inv( A**H ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*ad(nd, k, k))/a(k +C + , k) +C ENDDO +C b(i, k) = temp0 +C ENDDO +C ELSE +C DO i=1,m +C temp0 = CONJG(a(k, k)) +C temp1 = b(i, k)/temp0 +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp1*CONJG(ad(nd, k, k +C + )))/temp0 +C ENDDO +C b(i, k) = temp1 +C ENDDO +C END IF +C END IF +C DO j=1,k-1 +C IF (noconj) THEN +C DO nd=1,nbdirs +C tempd(nd) = ad(nd, j, k) +C ENDDO +C temp = a(j, k) +C ELSE +C DO nd=1,nbdirs +C tempd(nd) = CONJG(ad(nd, j, k)) +C ENDDO +C temp = CONJG(a(j, k)) +C END IF +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*tempd(nd) - temp +C + *bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - temp*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, k) = b(i, k)*alphad(nd) + alpha*bd(nd, i, k) +C ENDDO +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C temp1 = b(i, k)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp1*ad(nd, k, k))/a(k +C + , k) +C ENDDO +C b(i, k) = temp1 +C ENDDO +C ELSE +C DO i=1,m +C temp1 = CONJG(a(k, k)) +C temp0 = b(i, k)/temp1 +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*CONJG(ad(nd, k, k +C + )))/temp1 +C ENDDO +C b(i, k) = temp0 +C ENDDO +C END IF +C END IF +C DO j=k+1,n +C IF (noconj) THEN +C DO nd=1,nbdirs +C tempd(nd) = ad(nd, j, k) +C ENDDO +C temp = a(j, k) +C ELSE +C DO nd=1,nbdirs +C tempd(nd) = CONJG(ad(nd, j, k)) +C ENDDO +C temp = CONJG(a(j, k)) +C END IF +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*tempd(nd) - temp +C + *bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - temp*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, k) = b(i, k)*alphad(nd) + alpha*bd(nd, i, k) +C ENDDO +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C END IF +CC +C RETURN +CC +CC End of CTRSM +CC +C END IF +C END + + SUBROUTINE CTRSM_DV(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB, NBDIRS) +! +! Vector forward-mode derivative of CTRSM, black-box/Giles-style. +! Self-contained -- does not call CTRSM_D. +! + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB, NBDIRS + COMPLEX ALPHA + COMPLEX ALPHAD(NBDIRSMAX) + COMPLEX A(LDA,*), AD(NBDIRSMAX,LDA,*) + COMPLEX B(LDB,*), BD(NBDIRSMAX,LDB,*) + + COMPLEX X(M,N), T(M,N) + COMPLEX AD_SLICE(LDA,LDA), BD_SLICE(LDB,N) + INTEGER ND, I, J + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (M.EQ.0 .OR. N.EQ.0) RETURN + + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL CTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO ND = 1, NBDIRS + + DO J = 1, N + DO I = 1, M + AD_SLICE(I,J) = AD(ND,I,J) + BD_SLICE(I,J) = BD(ND,I,J) + END DO + END DO + + DO J = 1, N + DO I = 1, M + T(I,J) = X(I,J) + END DO + END DO + CALL CTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, (1.0E0,0.0E0), + + AD_SLICE, LDA, T, M) + + DO J = 1, N + DO I = 1, M + BD_SLICE(I,J) = ALPHAD(ND)*B(I,J) + ALPHA*BD_SLICE(I,J) + + - T(I,J) + END DO + END DO + + CALL CTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, (1.0E0,0.0E0), + + A, LDA, BD_SLICE, LDB) + + DO J = 1, N + DO I = 1, M + BD(ND,I,J) = BD_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE CTRSM_DV + diff --git a/BLAS/src/ctrsv_b.f b/BLAS/src/ctrsv_b.f new file mode 100644 index 0000000..2138f3b --- /dev/null +++ b/BLAS/src/ctrsv_b.f @@ -0,0 +1,869 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ctrsv in reverse (adjoint) mode: +C gradient of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:out +C> \brief \b CTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C COMPLEX A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> CTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, or A**H*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**H*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is COMPLEX array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE CTRSV_B(uplo, trans, diag, n, a, ab, lda, x, xb, incx) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX a(lda, *), x(*) +C COMPLEX ab(lda, *), xb(*) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C COMPLEX temp +C COMPLEX tempb +C INTEGER i, info, ix, j, jx, kx +C LOGICAL noconj, nounit +C EXTERNAL LSAME +C INTEGER ISIZE2OFA +CC .. +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC CONJG, MAX +C INTEGER max1 +C COMPLEX temp0 +C COMPLEX tempb0 +C INTEGER ad_from +C INTEGER*4 branch +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_from2 +C INTEGER ad_to +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_to2 +C INTEGER ad_to3 +C INTEGER ad_to4 +C INTEGER ad_to5 +C INTEGER ad_to6 +C INTEGER ii2 +C INTEGER ii1 +CC .. +CC +CC Test the input parameters. +CC +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(4) +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 8 +C ELSE +C CALL PUSHCONTROL3B(5) +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (n .EQ. 0) THEN +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ELSE +CC +C noconj = LSAME(trans, 'T') +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C CALL PUSHCONTROL1B(0) +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C CALL PUSHCONTROL1B(1) +C kx = 1 +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX8(temp) +C temp = x(j) +C ad_from = j - 1 +C DO i=ad_from,1,-1 +C CALL PUSHCOMPLEX8(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C tempb = (0.0,0.0) +C CALL POPINTEGER4(ad_from) +C DO i=1,ad_from,1 +C CALL POPCOMPLEX8(x(i)) +C tempb = tempb + CONJG(-a(i, j))*xb(i) +C ab(i, j) = ab(i, j) + CONJG(-temp)*xb(i) +C ENDDO +C CALL POPCOMPLEX8(temp) +C xb(j) = xb(j) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(x(j)) +C tempb0 = CONJG(1.0/a(j, j))*xb(j) +C xb(j) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(x(j)/a(j, j)))*tempb0 +C END IF +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX8(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from0 = j - 1 +C DO i=ad_from0,1,-1 +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C CALL PUSHCOMPLEX8(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C tempb = (0.0,0.0) +C CALL POPINTEGER4(ad_from0) +C DO i=1,ad_from0,1 +C CALL POPCOMPLEX8(x(ix)) +C tempb = tempb + CONJG(-a(i, j))*xb(ix) +C ab(i, j) = ab(i, j) + CONJG(-temp)*xb(ix) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPCOMPLEX8(temp) +C xb(jx) = xb(jx) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(x(jx)) +C tempb0 = CONJG(1.0/a(j, j))*xb(jx) +C xb(jx) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(x(jx)/a(j, j)))*tempb0 +C END IF +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX8(temp) +C temp = x(j) +C ad_from1 = j + 1 +C DO i=ad_from1,n +C CALL PUSHCOMPLEX8(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C tempb = (0.0,0.0) +C CALL POPINTEGER4(ad_from1) +C DO i=n,ad_from1,-1 +C CALL POPCOMPLEX8(x(i)) +C tempb = tempb + CONJG(-a(i, j))*xb(i) +C ab(i, j) = ab(i, j) + CONJG(-temp)*xb(i) +C ENDDO +C CALL POPCOMPLEX8(temp) +C xb(j) = xb(j) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(x(j)) +C tempb0 = CONJG(1.0/a(j, j))*xb(j) +C xb(j) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(x(j)/a(j, j)))*tempb0 +C END IF +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX8(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from2 = j + 1 +C DO i=ad_from2,n +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C CALL PUSHCOMPLEX8(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C tempb = (0.0,0.0) +C CALL POPINTEGER4(ad_from2) +C DO i=n,ad_from2,-1 +C CALL POPCOMPLEX8(x(ix)) +C tempb = tempb + CONJG(-a(i, j))*xb(ix) +C ab(i, j) = ab(i, j) + CONJG(-temp)*xb(ix) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPCOMPLEX8(temp) +C xb(jx) = xb(jx) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(x(jx)) +C tempb0 = CONJG(1.0/a(j, j))*xb(jx) +C xb(jx) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(x(jx)/a(j, j)))*tempb0 +C END IF +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x or x := inv( A**H )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C temp = x(j) +C IF (noconj) THEN +C DO i=1,j-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=1,j-1 +C temp = temp - CONJG(a(i, j))*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCOMPLEX8(x(j)) +C tempb = xb(j) +C xb(j) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C tempb0 = CONJG(1.0/a(j, j))*tempb +C tempb = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(temp/a(j, j)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C ab(i, j) = ab(i, j) + CONJG(-x(i))*tempb +C xb(i) = xb(i) + CONJG(-a(i, j))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(j, j)) +C ab(j, j) = ab(j, j) + CONJG(CONJG(-(temp/temp0**2))* +C + tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to0) +C DO i=ad_to0,1,-1 +C ab(i, j) = ab(i, j) + CONJG(CONJG(-x(i))*tempb) +C xb(i) = xb(i) + CONJG(-CONJG(a(i, j)))*tempb +C ENDDO +C END IF +C xb(j) = xb(j) + tempb +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C ix = kx +C temp = x(jx) +C IF (noconj) THEN +C DO i=1,j-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=1,j-1 +C temp = temp - CONJG(a(i, j))*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C CALL POPCOMPLEX8(x(jx)) +C tempb = xb(jx) +C xb(jx) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C tempb0 = CONJG(1.0/a(j, j))*tempb +C tempb = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(temp/a(j, j)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to1) +C DO i=ad_to1,1,-1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) + CONJG(-x(ix))*tempb +C xb(ix) = xb(ix) + CONJG(-a(i, j))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(j, j)) +C ab(j, j) = ab(j, j) + CONJG(CONJG(-(temp/temp0**2))* +C + tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to2) +C DO i=ad_to2,1,-1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) + CONJG(CONJG(-x(ix))*tempb) +C xb(ix) = xb(ix) + CONJG(-CONJG(a(i, j)))*tempb +C ENDDO +C END IF +C xb(jx) = xb(jx) + tempb +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C temp = x(j) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp = temp - CONJG(a(i, j))*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCOMPLEX8(x(j)) +C tempb = xb(j) +C xb(j) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C tempb0 = CONJG(1.0/a(j, j))*tempb +C tempb = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(temp/a(j, j)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to3) +C DO i=ad_to3,n,1 +C ab(i, j) = ab(i, j) + CONJG(-x(i))*tempb +C xb(i) = xb(i) + CONJG(-a(i, j))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(j, j)) +C ab(j, j) = ab(j, j) + CONJG(CONJG(-(temp/temp0**2))* +C + tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to4) +C DO i=ad_to4,n,1 +C ab(i, j) = ab(i, j) + CONJG(CONJG(-x(i))*tempb) +C xb(i) = xb(i) + CONJG(-CONJG(a(i, j)))*tempb +C ENDDO +C END IF +C xb(j) = xb(j) + tempb +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C ix = kx +C temp = x(jx) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp = temp - CONJG(a(i, j))*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C CALL POPCOMPLEX8(x(jx)) +C tempb = xb(jx) +C xb(jx) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C tempb0 = CONJG(1.0/a(j, j))*tempb +C tempb = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(temp/a(j, j)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to5) +C DO i=ad_to5,n,1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) + CONJG(-x(ix))*tempb +C xb(ix) = xb(ix) + CONJG(-a(i, j))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(j, j)) +C ab(j, j) = ab(j, j) + CONJG(CONJG(-(temp/temp0**2))* +C + tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to6) +C DO i=ad_to6,n,1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) + CONJG(CONJG(-x(ix))*tempb) +C xb(ix) = xb(ix) + CONJG(-CONJG(a(i, j)))*tempb +C ENDDO +C END IF +C xb(jx) = xb(jx) + tempb +C ENDDO +C END IF +C CALL POPCONTROL1B(branch) +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE CTRSV_B(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, INCX) +! +! Reverse-mode (adjoint) derivative of CTRSV, black-box/Giles-style, +! using the Wirtinger/CR-calculus convention (Ab = dL/dRe(A) + i*dL/dIm(A)). +! X is read-only. Handles all three TRANS cases distinctly, since +! TRANS='T' needs a conjugate-both-sides trick (conj(A) isn't directly +! expressible as a CTRSV op flag). +! + IMPLICIT NONE + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX + COMPLEX A(LDA,*), AB(LDA,*) + COMPLEX X(*), XB(*) + + COMPLEX BLOC(N), S(N), YB(N) + LOGICAL UPPER, UNIT, ISN, IST, ISC + INTEGER I, J, KX + INTRINSIC CONJG + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + ISN = (TRANS.EQ.'N' .OR. TRANS.EQ.'n') + IST = (TRANS.EQ.'T' .OR. TRANS.EQ.'t') + ISC = (TRANS.EQ.'C' .OR. TRANS.EQ.'c') + + DO I = 1, N + BLOC(I) = X(KX + (I-1)*INCX) + YB(I) = XB(KX + (I-1)*INCX) + END DO + +C Solve M^H*Yb = seed, where M = op(A). Three distinct cases. + IF (ISN) THEN + CALL CTRSV(UPLO, 'C', DIAG, N, A, LDA, YB, 1) + ELSE IF (ISC) THEN + CALL CTRSV(UPLO, 'N', DIAG, N, A, LDA, YB, 1) + ELSE +C TRANS='T': conj(A)*Yb=seed <=> A*conj(Yb)=conj(seed) + DO I = 1, N + YB(I) = CONJG(YB(I)) + END DO + CALL CTRSV(UPLO, 'N', DIAG, N, A, LDA, YB, 1) + DO I = 1, N + YB(I) = CONJG(YB(I)) + END DO + END IF + +C Recompute S from the original, untouched B + DO I = 1, N + S(I) = BLOC(I) + END DO + CALL CTRSV(UPLO, TRANS, DIAG, N, A, LDA, S, 1) + + DO J = 1, LDA + DO I = 1, LDA + AB(I,J) = (0.0E0, 0.0E0) + END DO + END DO + + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + AB(I,J) = -YB(I)*CONJG(S(J)) + ELSE IF (IST) THEN + AB(I,J) = -YB(J)*CONJG(S(I)) + ELSE + AB(I,J) = -CONJG(YB(J))*S(I) + END IF + END IF + END IF + END DO + END DO + +C Bb = Yb (no alpha in TRSV) + DO I = 1, N + XB(KX + (I-1)*INCX) = YB(I) + END DO + + RETURN + END SUBROUTINE CTRSV_B + diff --git a/BLAS/src/ctrsv_bv.f b/BLAS/src/ctrsv_bv.f new file mode 100644 index 0000000..f8652f9 --- /dev/null +++ b/BLAS/src/ctrsv_bv.f @@ -0,0 +1,1014 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ctrsv in reverse (adjoint) mode (with options multiDirectional): +C gradient of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:out +C> \brief \b CTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C COMPLEX A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> CTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, or A**H*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**H*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is COMPLEX array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE CTRSV_BV(uplo, trans, diag, n, a, ab, lda, x, xb, incx +C + , nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX a(lda, *), x(*) +C COMPLEX ab(nbdirsmax, lda, *), xb(nbdirsmax, *) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C COMPLEX temp +C COMPLEX tempb(nbdirsmax) +C INTEGER i, info, ix, j, jx, kx +C LOGICAL noconj, nounit +C EXTERNAL LSAME +C INTEGER ISIZE2OFA +CC .. +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC CONJG, MAX +C INTEGER max1 +C INTEGER nd +C COMPLEX temp0 +C COMPLEX tempb0(nbdirsmax) +C INTEGER ad_from +C INTEGER*4 branch +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_from2 +C INTEGER ad_to +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_to2 +C INTEGER ad_to3 +C INTEGER ad_to4 +C INTEGER ad_to5 +C INTEGER ad_to6 +C INTEGER ii2 +C INTEGER ii1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(4) +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 8 +C ELSE +C CALL PUSHCONTROL3B(5) +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (n .EQ. 0) THEN +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C ELSE +CC +C noconj = LSAME(trans, 'T') +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C CALL PUSHCONTROL1B(0) +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C CALL PUSHCONTROL1B(1) +C kx = 1 +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX8(temp) +C temp = x(j) +C ad_from = j - 1 +C DO i=ad_from,1,-1 +C CALL PUSHCOMPLEX8(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C CALL POPINTEGER4(ad_from) +C DO i=1,ad_from,1 +C CALL POPCOMPLEX8(x(i)) +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) + CONJG(-a(i, j))*xb(nd, i) +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-temp)*xb(nd, +C + i) +C ENDDO +C ENDDO +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(x(j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*xb(nd, j) +C xb(nd, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(x(j)/a(j, j) +C + ))*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX8(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from0 = j - 1 +C DO i=ad_from0,1,-1 +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C CALL PUSHCOMPLEX8(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C CALL POPINTEGER4(ad_from0) +C DO i=1,ad_from0,1 +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) + CONJG(-a(i, j))*xb(nd, ix) +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-temp)*xb(nd, +C + ix) +C ENDDO +C CALL POPCOMPLEX8(x(ix)) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(x(jx)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*xb(nd, jx) +C xb(nd, jx) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(x(jx)/a(j, j +C + )))*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX8(temp) +C temp = x(j) +C ad_from1 = j + 1 +C DO i=ad_from1,n +C CALL PUSHCOMPLEX8(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C CALL POPINTEGER4(ad_from1) +C DO i=n,ad_from1,-1 +C CALL POPCOMPLEX8(x(i)) +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) + CONJG(-a(i, j))*xb(nd, i) +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-temp)*xb(nd, i) +C ENDDO +C ENDDO +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(x(j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*xb(nd, j) +C xb(nd, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(x(j)/a(j, j))) +C + *tempb0(nd) +C ENDDO +C END IF +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX8(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from2 = j + 1 +C DO i=ad_from2,n +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C CALL PUSHCOMPLEX8(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C CALL POPINTEGER4(ad_from2) +C DO i=n,ad_from2,-1 +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) + CONJG(-a(i, j))*xb(nd, ix) +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-temp)*xb(nd, ix +C + ) +C ENDDO +C CALL POPCOMPLEX8(x(ix)) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(x(jx)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*xb(nd, jx) +C xb(nd, jx) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(x(jx)/a(j, j)) +C + )*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x or x := inv( A**H )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C temp = x(j) +C IF (noconj) THEN +C DO i=1,j-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=1,j-1 +C temp = temp - CONJG(a(i, j))*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCOMPLEX8(x(j)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, j) +C xb(nd, j) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(temp/a(j, j) +C + ))*tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-x(i))*tempb( +C + nd) +C xb(nd, i) = xb(nd, i) + CONJG(-a(i, j))*tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(j, j)) +C DO nd=1,nbdirs +C ab(nd, j, j) = ab(nd, j, j) + CONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to0) +C DO i=ad_to0,1,-1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(CONJG(-x(i))* +C + tempb(nd)) +C xb(nd, i) = xb(nd, i) + CONJG(-CONJG(a(i, j)))* +C + tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C ix = kx +C temp = x(jx) +C IF (noconj) THEN +C DO i=1,j-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=1,j-1 +C temp = temp - CONJG(a(i, j))*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C CALL POPCOMPLEX8(x(jx)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, jx) +C xb(nd, jx) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(temp/a(j, j) +C + ))*tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO i=ad_to1,1,-1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-x(ix))*tempb( +C + nd) +C xb(nd, ix) = xb(nd, ix) + CONJG(-a(i, j))*tempb(nd +C + ) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(j, j)) +C DO nd=1,nbdirs +C ab(nd, j, j) = ab(nd, j, j) + CONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to2) +C DO i=ad_to2,1,-1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(CONJG(-x(ix))* +C + tempb(nd)) +C xb(nd, ix) = xb(nd, ix) + CONJG(-CONJG(a(i, j)))* +C + tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C temp = x(j) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp = temp - CONJG(a(i, j))*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCOMPLEX8(x(j)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, j) +C xb(nd, j) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(temp/a(j, j))) +C + *tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to3) +C DO i=ad_to3,n,1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-x(i))*tempb(nd) +C xb(nd, i) = xb(nd, i) + CONJG(-a(i, j))*tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(j, j)) +C DO nd=1,nbdirs +C ab(nd, j, j) = ab(nd, j, j) + CONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to4) +C DO i=ad_to4,n,1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(CONJG(-x(i))* +C + tempb(nd)) +C xb(nd, i) = xb(nd, i) + CONJG(-CONJG(a(i, j)))*tempb +C + (nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C ix = kx +C temp = x(jx) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp = temp - CONJG(a(i, j))*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX8(temp) +C temp = temp/CONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX8(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C CALL POPCOMPLEX8(x(jx)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, jx) +C xb(nd, jx) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX8(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(temp/a(j, j))) +C + *tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to5) +C DO i=ad_to5,n,1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-x(ix))*tempb(nd +C + ) +C xb(nd, ix) = xb(nd, ix) + CONJG(-a(i, j))*tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX8(temp) +C temp0 = CONJG(a(j, j)) +C DO nd=1,nbdirs +C ab(nd, j, j) = ab(nd, j, j) + CONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to6) +C DO i=ad_to6,n,1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(CONJG(-x(ix))* +C + tempb(nd)) +C xb(nd, ix) = xb(nd, ix) + CONJG(-CONJG(a(i, j)))* +C + tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C ENDDO +C END IF +C CALL POPCONTROL1B(branch) +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE CTRSV_BV(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, + + INCX, NBDIRS) +! +! Vector reverse-mode (adjoint) derivative of CTRSV, black-box/Giles-style. +! Self-contained -- does not call CTRSV_B. Wirtinger/CR-calculus convention, +! same three-way TRANS branching as CTRSV_B (TRANS='T' needs the +! conjugate-both-sides trick since conj(A) isn't a direct CTRSV op flag). +! + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX, NBDIRS + COMPLEX A(LDA,*), AB(NBDIRSMAX,LDA,*) + COMPLEX X(*), XB(NBDIRSMAX,*) + + COMPLEX BLOC(N), S(N), YB(N), AB_SLICE(LDA,LDA) + LOGICAL UPPER, UNIT, ISN, IST, ISC + INTEGER ND, I, J, KX + INTRINSIC CONJG + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + ISN = (TRANS.EQ.'N' .OR. TRANS.EQ.'n') + IST = (TRANS.EQ.'T' .OR. TRANS.EQ.'t') + ISC = (TRANS.EQ.'C' .OR. TRANS.EQ.'c') + +C Gather original B once, recompute S once (shared across directions) + DO I = 1, N + BLOC(I) = X(KX + (I-1)*INCX) + END DO + DO I = 1, N + S(I) = BLOC(I) + END DO + CALL CTRSV(UPLO, TRANS, DIAG, N, A, LDA, S, 1) + + DO ND = 1, NBDIRS + + DO I = 1, N + YB(I) = XB(ND, KX + (I-1)*INCX) + END DO + +C Solve M^H*Yb = seed, where M = op(A). Three distinct cases. + IF (ISN) THEN + CALL CTRSV(UPLO, 'C', DIAG, N, A, LDA, YB, 1) + ELSE IF (ISC) THEN + CALL CTRSV(UPLO, 'N', DIAG, N, A, LDA, YB, 1) + ELSE + DO I = 1, N + YB(I) = CONJG(YB(I)) + END DO + CALL CTRSV(UPLO, 'N', DIAG, N, A, LDA, YB, 1) + DO I = 1, N + YB(I) = CONJG(YB(I)) + END DO + END IF + + DO J = 1, LDA + DO I = 1, LDA + AB_SLICE(I,J) = (0.0E0, 0.0E0) + END DO + END DO + + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + AB_SLICE(I,J) = -YB(I)*CONJG(S(J)) + ELSE IF (IST) THEN + AB_SLICE(I,J) = -YB(J)*CONJG(S(I)) + ELSE + AB_SLICE(I,J) = -CONJG(YB(J))*S(I) + END IF + END IF + END IF + END DO + END DO + +C Bb = Yb -- scatter into XB + DO I = 1, N + XB(ND, KX + (I-1)*INCX) = YB(I) + END DO + DO J = 1, LDA + DO I = 1, LDA + AB(ND,I,J) = AB_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE CTRSV_BV + diff --git a/BLAS/src/ctrsv_d.f b/BLAS/src/ctrsv_d.f new file mode 100644 index 0000000..b4f8d78 --- /dev/null +++ b/BLAS/src/ctrsv_d.f @@ -0,0 +1,498 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ctrsv in forward (tangent) mode: +C variations of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:in +C> \brief \b CTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C COMPLEX A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> CTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, or A**H*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**H*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is COMPLEX array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE CTRSV_D(uplo, trans, diag, n, a, ad, lda, x, xd, incx) +C IMPLICIT NONE +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX a(lda, *), x(*) +C COMPLEX ad(lda, *), xd(*) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C COMPLEX temp +C COMPLEX tempd +C INTEGER i, info, ix, j, jx, kx +C LOGICAL noconj, nounit +C EXTERNAL LSAME +CC .. +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC CONJG, MAX +C INTEGER max1 +C COMPLEX temp0 +CC .. +CC +CC Test the input parameters. +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 3 +C ELSE IF (n .LT. 0) THEN +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C info = 8 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('CTRSV ', info) +C RETURN +C ELSE IF (n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE +CC +C noconj = LSAME(trans, 'T') +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C kx = 1 +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) +C x(j) = temp0 +C END IF +C tempd = xd(j) +C temp = x(j) +C DO i=j-1,1,-1 +C xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) +C x(jx) = temp0 +C END IF +C tempd = xd(jx) +C temp = x(jx) +C ix = jx +C DO i=j-1,1,-1 +C ix = ix - incx +C xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx - incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) +C x(j) = temp0 +C END IF +C tempd = xd(j) +C temp = x(j) +C DO i=j+1,n +C xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) +C x(jx) = temp0 +C END IF +C tempd = xd(jx) +C temp = x(jx) +C ix = jx +C DO i=j+1,n +C ix = ix + incx +C xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x or x := inv( A**H )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C tempd = xd(j) +C temp = x(j) +C IF (noconj) THEN +C DO i=1,j-1 +C tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C ELSE +C DO i=1,j-1 +C temp0 = CONJG(a(i, j)) +C tempd = tempd - x(i)*CONJG(ad(i, j)) - temp0*xd(i) +C temp = temp - temp0*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(j, j)) +C tempd = (tempd-temp*CONJG(ad(j, j))/temp0)/temp0 +C temp = temp/temp0 +C END IF +C END IF +C xd(j) = tempd +C x(j) = temp +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C ix = kx +C tempd = xd(jx) +C temp = x(jx) +C IF (noconj) THEN +C DO i=1,j-1 +C tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) +C temp = temp - a(i, j)*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C ELSE +C DO i=1,j-1 +C temp0 = CONJG(a(i, j)) +C tempd = tempd - x(ix)*CONJG(ad(i, j)) - temp0*xd(ix) +C temp = temp - temp0*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(j, j)) +C tempd = (tempd-temp*CONJG(ad(j, j))/temp0)/temp0 +C temp = temp/temp0 +C END IF +C END IF +C xd(jx) = tempd +C x(jx) = temp +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C tempd = xd(j) +C temp = x(j) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp0 = CONJG(a(i, j)) +C tempd = tempd - x(i)*CONJG(ad(i, j)) - temp0*xd(i) +C temp = temp - temp0*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(j, j)) +C tempd = (tempd-temp*CONJG(ad(j, j))/temp0)/temp0 +C temp = temp/temp0 +C END IF +C END IF +C xd(j) = tempd +C x(j) = temp +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C ix = kx +C tempd = xd(jx) +C temp = x(jx) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) +C temp = temp - a(i, j)*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp0 = CONJG(a(i, j)) +C tempd = tempd - x(ix)*CONJG(ad(i, j)) - temp0*xd(ix) +C temp = temp - temp0*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(j, j)) +C tempd = (tempd-temp*CONJG(ad(j, j))/temp0)/temp0 +C temp = temp/temp0 +C END IF +C END IF +C xd(jx) = tempd +C x(jx) = temp +C jx = jx - incx +C ENDDO +C END IF +CC +C RETURN +CC +CC End of CTRSV +CC +C END IF +C END + + SUBROUTINE CTRSV_D(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, INCX) +! +! Forward-mode derivative of CTRSV, black-box/Giles-style. Passing the +! SAME trans flag to CTRMV/CTRSV as the primal call automatically +! applies the correct conjugation for TRANS='C' -- no manual CONJG needed. +! + IMPLICIT NONE + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX + COMPLEX A(LDA,*), AD(LDA,*) + COMPLEX X(*), XD(*) + + COMPLEX S(N), W(N) + INTEGER I, KX + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + CALL CTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + DO I = 1, N + S(I) = X(KX + (I-1)*INCX) + END DO + + DO I = 1, N + W(I) = S(I) + END DO + CALL CTRMV(UPLO, TRANS, DIAG, N, AD, LDA, W, 1) + + DO I = 1, N + W(I) = XD(KX + (I-1)*INCX) - W(I) + END DO + + CALL CTRSV(UPLO, TRANS, DIAG, N, A, LDA, W, 1) + + DO I = 1, N + XD(KX + (I-1)*INCX) = W(I) + END DO + + RETURN + END SUBROUTINE CTRSV_D + diff --git a/BLAS/src/ctrsv_dv.f b/BLAS/src/ctrsv_dv.f new file mode 100644 index 0000000..1c80513 --- /dev/null +++ b/BLAS/src/ctrsv_dv.f @@ -0,0 +1,619 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ctrsv in forward (tangent) mode (with options multiDirectional): +C variations of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:in +C> \brief \b CTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C COMPLEX A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> CTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, or A**H*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**H*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is COMPLEX array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE CTRSV_DV(uplo, trans, diag, n, a, ad, lda, x, xd, incx +C + , nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX a(lda, *), x(*) +C COMPLEX ad(nbdirsmax, lda, *), xd(nbdirsmax, *) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C COMPLEX temp +C COMPLEX tempd(nbdirsmax) +C INTEGER i, info, ix, j, jx, kx +C LOGICAL noconj, nounit +C EXTERNAL LSAME +CC .. +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC CONJG, MAX +C INTEGER max1 +C INTEGER nd +C COMPLEX temp0 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 3 +C ELSE IF (n .LT. 0) THEN +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C info = 8 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('CTRSV ', info) +C RETURN +C ELSE IF (n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE +CC +C noconj = LSAME(trans, 'T') +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C kx = 1 +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(j) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=j-1,1,-1 +C DO nd=1,nbdirs +C xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad( +C + nd, i, j) +C ENDDO +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(jx) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = jx +C DO i=j-1,1,-1 +C ix = ix - incx +C DO nd=1,nbdirs +C xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp* +C + ad(nd, i, j) +C ENDDO +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx - incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(j) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=j+1,n +C DO nd=1,nbdirs +C xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad(nd +C + , i, j) +C ENDDO +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(jx) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = jx +C DO i=j+1,n +C ix = ix + incx +C DO nd=1,nbdirs +C xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp*ad( +C + nd, i, j) +C ENDDO +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x or x := inv( A**H )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C IF (noconj) THEN +C DO i=1,j-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)* +C + xd(nd, i) +C ENDDO +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO i=1,j-1 +C temp0 = CONJG(a(i, j)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*CONJG(ad(nd, i, j)) - +C + temp0*xd(nd, i) +C ENDDO +C temp = temp - temp0*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(j, j)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*CONJG(ad(nd, j, j))/ +C + temp0)/temp0 +C ENDDO +C temp = temp/temp0 +C END IF +C END IF +C DO nd=1,nbdirs +C xd(nd, j) = tempd(nd) +C ENDDO +C x(j) = temp +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C ix = kx +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C IF (noconj) THEN +C DO i=1,j-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j) +C + *xd(nd, ix) +C ENDDO +C temp = temp - a(i, j)*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO i=1,j-1 +C temp0 = CONJG(a(i, j)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*CONJG(ad(nd, i, j)) - +C + temp0*xd(nd, ix) +C ENDDO +C temp = temp - temp0*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(j, j)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*CONJG(ad(nd, j, j))/ +C + temp0)/temp0 +C ENDDO +C temp = temp/temp0 +C END IF +C END IF +C DO nd=1,nbdirs +C xd(nd, jx) = tempd(nd) +C ENDDO +C x(jx) = temp +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd +C + (nd, i) +C ENDDO +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp0 = CONJG(a(i, j)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*CONJG(ad(nd, i, j)) - +C + temp0*xd(nd, i) +C ENDDO +C temp = temp - temp0*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(j, j)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*CONJG(ad(nd, j, j))/temp0) +C + /temp0 +C ENDDO +C temp = temp/temp0 +C END IF +C END IF +C DO nd=1,nbdirs +C xd(nd, j) = tempd(nd) +C ENDDO +C x(j) = temp +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C ix = kx +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)* +C + xd(nd, ix) +C ENDDO +C temp = temp - a(i, j)*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp0 = CONJG(a(i, j)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*CONJG(ad(nd, i, j)) - +C + temp0*xd(nd, ix) +C ENDDO +C temp = temp - temp0*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = CONJG(a(j, j)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*CONJG(ad(nd, j, j))/temp0) +C + /temp0 +C ENDDO +C temp = temp/temp0 +C END IF +C END IF +C DO nd=1,nbdirs +C xd(nd, jx) = tempd(nd) +C ENDDO +C x(jx) = temp +C jx = jx - incx +C ENDDO +C END IF +CC +C RETURN +CC +CC End of CTRSV +CC +C END IF +C END + + SUBROUTINE CTRSV_DV(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, + + INCX, NBDIRS) +! +! Vector forward-mode derivative of CTRSV, black-box/Giles-style. +! Self-contained -- does not call CTRSV_D. Passing the SAME trans flag +! to CTRMV as the primal call automatically handles TRANS='C' conjugation. +! + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX, NBDIRS + COMPLEX A(LDA,*), AD(NBDIRSMAX,LDA,*) + COMPLEX X(*), XD(NBDIRSMAX,*) + + COMPLEX S(N), T(N), W(N), AD_SLICE(LDA,LDA) + INTEGER ND, I, J, KX + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + +C S = solution, overwriting X in place (same for every direction) + CALL CTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + DO I = 1, N + S(I) = X(KX + (I-1)*INCX) + END DO + + DO ND = 1, NBDIRS + + DO J = 1, N + DO I = 1, N + AD_SLICE(I,J) = AD(ND,I,J) + END DO + END DO + +C T = op(Ad)*S (local copy, S stays untouched) + DO I = 1, N + T(I) = S(I) + END DO + CALL CTRMV(UPLO, TRANS, DIAG, N, AD_SLICE, LDA, T, 1) + +C RHS = Xd_in - T, gathered respecting INCX + DO I = 1, N + W(I) = XD(ND, KX + (I-1)*INCX) - T(I) + END DO + + CALL CTRSV(UPLO, TRANS, DIAG, N, A, LDA, W, 1) + + DO I = 1, N + XD(ND, KX + (I-1)*INCX) = W(I) + END DO + + END DO + + RETURN + END SUBROUTINE CTRSV_DV + diff --git a/BLAS/src/ztrsm_b.f b/BLAS/src/ztrsm_b.f new file mode 100644 index 0000000..dc0e60b --- /dev/null +++ b/BLAS/src/ztrsm_b.f @@ -0,0 +1,1057 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ztrsm in reverse (adjoint) mode: +C gradient of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:out a:out b:in-out +C> \brief \b ZTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C COMPLEX*16 ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C COMPLEX*16 A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> ZTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**H. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is COMPLEX*16 +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX*16 array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is COMPLEX*16 array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE ZTRSM_B(side, uplo, transa, diag, m, n, alpha, alphab, +C + a, ab, lda, b, bb, ldb) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C COMPLEX*16 alpha +C COMPLEX*16 alphab +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX*16 a(lda, *), b(ldb, *) +C COMPLEX*16 ab(lda, *), bb(ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC DCONJG, MAX +CC .. +CC .. Local Scalars .. +C COMPLEX*16 temp +C COMPLEX*16 tempb +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, noconj, nounit, upper +C INTEGER ISIZE2OFA +CC .. +CC .. Parameters .. +C COMPLEX*16 zero +C PARAMETER (zero=(0.0d+0,0.0d+0)) +C INTEGER max1 +C INTEGER max2 +C COMPLEX*16 tempb0 +C COMPLEX*16 tmp +C COMPLEX*16 tmpb +C COMPLEX*16 tmp0 +C COMPLEX*16 tmpb0 +C DOUBLE COMPLEX temp0 +C COMPLEX*16 tmp1 +C COMPLEX*16 tmpb1 +C COMPLEX*16 tmp2 +C COMPLEX*16 tmpb2 +C COMPLEX*16 tmp3 +C COMPLEX*16 tmpb3 +C COMPLEX*16 tmp4 +C COMPLEX*16 tmpb4 +C INTEGER ad_to +C INTEGER*4 branch +C INTEGER ad_from +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_to2 +C INTEGER ad_from2 +C INTEGER ad_to3 +C INTEGER ad_from3 +C INTEGER ii2 +C INTEGER ii1 +CC .. +CC +CC Test the input parameters. +CC +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C noconj = LSAME(transa, 'T') +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE IF (m .LT. 0) THEN +C CALL PUSHCONTROL3B(4) +C info = 5 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(6) +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) THEN +C CALL PUSHCONTROL3B(7) +C info = 11 +C ELSE +C CALL PUSHCONTROL3B(7) +C END IF +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (m .EQ. 0 .OR. n .EQ. 0) THEN +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=n,1,-1 +C DO i=m,1,-1 +C bb(i, j) = (0.0,0.0) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ELSE IF (lside) THEN +CC +CC Start the operations. +CC +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,k-1 +C tmp = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=1,m,1 +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tmpb = bb(i, j) +C bb(i, j) = tmpb +C bb(k, j) = bb(k, j) + CONJG(-a(i, k))*tmpb +C ab(i, k) = ab(i, k) + CONJG(-b(k, j))*tmpb +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPCOMPLEX16(b(k, j)) +C tempb0 = CONJG(1.0/a(k, k))*bb(k, j) +C bb(k, j) = tempb0 +C ab(k, k) = ab(k, k) + CONJG(-(b(k, j)/a(k, k)))* +C + tempb0 +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C alphab = alphab + CONJG(b(i, j))*bb(i, j) +C bb(i, j) = CONJG(alpha)*bb(i, j) +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from = k + 1 +C DO i=ad_from,m +C tmp0 = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp0 +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=m,1,-1 +C CALL POPINTEGER4(ad_from) +C DO i=m,ad_from,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tmpb0 = bb(i, j) +C bb(i, j) = tmpb0 +C bb(k, j) = bb(k, j) + CONJG(-a(i, k))*tmpb0 +C ab(i, k) = ab(i, k) + CONJG(-b(k, j))*tmpb0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPCOMPLEX16(b(k, j)) +C tempb0 = CONJG(1.0/a(k, k))*bb(k, j) +C bb(k, j) = tempb0 +C ab(k, k) = ab(k, k) + CONJG(-(b(k, j)/a(k, k)))* +C + tempb0 +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C alphab = alphab + CONJG(b(i, j))*bb(i, j) +C bb(i, j) = CONJG(alpha)*bb(i, j) +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B +CC or B := alpha*inv( A**H )*B. +CC +C DO j=1,n +C DO i=1,m +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=1,i-1 +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO k=1,i-1 +C temp = temp - DCONJG(a(k, i))*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(i, i)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tempb = bb(i, j) +C bb(i, j) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C tempb0 = CONJG(1.0/a(i, i))*tempb +C tempb = tempb0 +C ab(i, i) = ab(i, i) + CONJG(-(temp/a(i, i)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to0) +C DO k=ad_to0,1,-1 +C ab(k, i) = ab(k, i) + CONJG(-b(k, j))*tempb +C bb(k, j) = bb(k, j) + CONJG(-a(k, i))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(i, i)) +C ab(i, i) = ab(i, i) + DCONJG(CONJG(-(temp/temp0**2)) +C + *tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to1) +C DO k=ad_to1,1,-1 +C ab(k, i) = ab(k, i) + DCONJG(CONJG(-b(k, j))*tempb) +C bb(k, j) = bb(k, j) + CONJG(-DCONJG(a(k, i)))*tempb +C ENDDO +C END IF +C alphab = alphab + CONJG(b(i, j))*tempb +C bb(i, j) = bb(i, j) + CONJG(alpha)*tempb +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C temp = alpha*b(i, j) +C IF (noconj) THEN +C ad_from0 = i + 1 +C DO k=ad_from0,m +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C ad_from1 = i + 1 +C DO k=ad_from1,m +C temp = temp - DCONJG(a(k, i))*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(i, i)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=1,m,1 +C CALL POPCOMPLEX16(b(i, j)) +C tempb = bb(i, j) +C bb(i, j) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C tempb0 = CONJG(1.0/a(i, i))*tempb +C tempb = tempb0 +C ab(i, i) = ab(i, i) + CONJG(-(temp/a(i, i)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_from0) +C DO k=m,ad_from0,-1 +C ab(k, i) = ab(k, i) + CONJG(-b(k, j))*tempb +C bb(k, j) = bb(k, j) + CONJG(-a(k, i))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(i, i)) +C ab(i, i) = ab(i, i) + DCONJG(CONJG(-(temp/temp0**2)) +C + *tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_from1) +C DO k=m,ad_from1,-1 +C ab(k, i) = ab(k, i) + DCONJG(CONJG(-b(k, j))*tempb) +C bb(k, j) = bb(k, j) + CONJG(-DCONJG(a(k, i)))*tempb +C ENDDO +C END IF +C alphab = alphab + CONJG(b(i, j))*tempb +C bb(i, j) = bb(i, j) + CONJG(alpha)*tempb +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C tmp1 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp1 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tempb0 = CONJG(1.0/a(j, j))*bb(i, j) +C bb(i, j) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(b(i, j)/a(j, j)))*tempb0 +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to2) +C DO k=ad_to2,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tmpb1 = bb(i, j) +C bb(i, j) = tmpb1 +C ab(k, j) = ab(k, j) + CONJG(-b(i, k))*tmpb1 +C bb(i, k) = bb(i, k) + CONJG(-a(k, j))*tmpb1 +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C alphab = alphab + CONJG(b(i, j))*bb(i, j) +C bb(i, j) = CONJG(alpha)*bb(i, j) +C ENDDO +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C ad_from2 = j + 1 +C DO k=ad_from2,n +C DO i=1,m +C tmp2 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp2 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tempb0 = CONJG(1.0/a(j, j))*bb(i, j) +C bb(i, j) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(b(i, j)/a(j, j)))*tempb0 +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from2) +C DO k=n,ad_from2,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tmpb2 = bb(i, j) +C bb(i, j) = tmpb2 +C ab(k, j) = ab(k, j) + CONJG(-b(i, k))*tmpb2 +C bb(i, k) = bb(i, k) + CONJG(-a(k, j))*tmpb2 +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C alphab = alphab + CONJG(b(i, j))*bb(i, j) +C bb(i, j) = CONJG(alpha)*bb(i, j) +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ) +CC or B := alpha*B*inv( A**H ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL2B(2) +C ELSE +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = b(i, k)/DCONJG(a(k, k)) +C ENDDO +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C CALL PUSHCONTROL2B(0) +C END IF +C DO j=1,k-1 +C IF (noconj) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = a(j, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCOMPLEX16(temp) +C temp = DCONJG(a(j, k)) +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,m +C tmp3 = b(i, j) - temp*b(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp3 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(j - 1) +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO k=1,n,1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C alphab = alphab + CONJG(b(i, k))*bb(i, k) +C bb(i, k) = CONJG(alpha)*bb(i, k) +C ENDDO +C CALL POPINTEGER4(ad_to3) +C DO j=ad_to3,1,-1 +C tempb = (0.0,0.0) +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tmpb3 = bb(i, j) +C bb(i, j) = tmpb3 +C tempb = tempb + CONJG(-b(i, k))*tmpb3 +C bb(i, k) = bb(i, k) + CONJG(-temp)*tmpb3 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C ab(j, k) = ab(j, k) + DCONJG(tempb) +C ELSE +C CALL POPCOMPLEX16(temp) +C ab(j, k) = ab(j, k) + tempb +C END IF +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .NE. 0) THEN +C IF (branch .EQ. 1) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C temp0 = DCONJG(a(k, k)) +C ab(k, k) = ab(k, k) + DCONJG(CONJG(-(b(i, k)/temp0**2) +C + )*bb(i, k)) +C bb(i, k) = CONJG(1.0/temp0)*bb(i, k) +C ENDDO +C ELSE +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C tempb0 = CONJG(1.0/a(k, k))*bb(i, k) +C bb(i, k) = tempb0 +C ab(k, k) = ab(k, k) + CONJG(-(b(i, k)/a(k, k)))*tempb0 +C ENDDO +C END IF +C END IF +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL2B(2) +C ELSE +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = b(i, k)/DCONJG(a(k, k)) +C ENDDO +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C CALL PUSHCONTROL2B(0) +C END IF +C ad_from3 = k + 1 +C DO j=ad_from3,n +C IF (noconj) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = a(j, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCOMPLEX16(temp) +C temp = DCONJG(a(j, k)) +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,m +C tmp4 = b(i, j) - temp*b(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp4 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from3) +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C alphab = (0.0,0.0) +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO k=n,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C alphab = alphab + CONJG(b(i, k))*bb(i, k) +C bb(i, k) = CONJG(alpha)*bb(i, k) +C ENDDO +C CALL POPINTEGER4(ad_from3) +C DO j=n,ad_from3,-1 +C tempb = (0.0,0.0) +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C tmpb4 = bb(i, j) +C bb(i, j) = tmpb4 +C tempb = tempb + CONJG(-b(i, k))*tmpb4 +C bb(i, k) = bb(i, k) + CONJG(-temp)*tmpb4 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C ab(j, k) = ab(j, k) + DCONJG(tempb) +C ELSE +C CALL POPCOMPLEX16(temp) +C ab(j, k) = ab(j, k) + tempb +C END IF +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .NE. 0) THEN +C IF (branch .EQ. 1) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C temp0 = DCONJG(a(k, k)) +C ab(k, k) = ab(k, k) + DCONJG(CONJG(-(b(i, k)/temp0**2) +C + )*bb(i, k)) +C bb(i, k) = CONJG(1.0/temp0)*bb(i, k) +C ENDDO +C ELSE +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C tempb0 = CONJG(1.0/a(k, k))*bb(i, k) +C bb(i, k) = tempb0 +C ab(k, k) = ab(k, k) + CONJG(-(b(i, k)/a(k, k)))*tempb0 +C ENDDO +C END IF +C END IF +C ENDDO +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE ZTRSM_B(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB) + IMPLICIT NONE + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + COMPLEX*16 ALPHA, ALPHAB + COMPLEX*16 A(LDA,*), AB(LDA,*) + COMPLEX*16 B(LDB,*), BB(LDB,*) + + COMPLEX*16 X(M,N), BLOC(M,N) + LOGICAL LEFT, UPPER, UNIT, ISN, IST, ISC + INTEGER I, J, K + INTRINSIC DCONJG + + LEFT = (SIDE.EQ.'L' .OR. SIDE.EQ.'l') + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + ISN = (TRANSA.EQ.'N' .OR. TRANSA.EQ.'n') + IST = (TRANSA.EQ.'T' .OR. TRANSA.EQ.'t') + ISC = (TRANSA.EQ.'C' .OR. TRANSA.EQ.'c') + + IF (M.EQ.0 .OR. N.EQ.0) THEN + ALPHAB = (0.0D0,0.0D0) + RETURN + END IF + + DO J = 1, N + DO I = 1, M + BLOC(I,J) = B(I,J) + END DO + END DO + + IF (ISN) THEN + CALL ZTRSM(SIDE, UPLO, 'C', DIAG, M, N, (1.0D0,0.0D0), + + A, LDA, BB, LDB) + ELSE IF (ISC) THEN + CALL ZTRSM(SIDE, UPLO, 'N', DIAG, M, N, (1.0D0,0.0D0), + + A, LDA, BB, LDB) + ELSE + DO J = 1, N + DO I = 1, M + BB(I,J) = DCONJG(BB(I,J)) + END DO + END DO + CALL ZTRSM(SIDE, UPLO, 'N', DIAG, M, N, (1.0D0,0.0D0), + + A, LDA, BB, LDB) + DO J = 1, N + DO I = 1, M + BB(I,J) = DCONJG(BB(I,J)) + END DO + END DO + END IF + + DO J = 1, N + DO I = 1, M + X(I,J) = BLOC(I,J) + END DO + END DO + CALL ZTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + ALPHAB = (0.0D0,0.0D0) + DO J = 1, N + DO I = 1, M + ALPHAB = ALPHAB + BB(I,J)*DCONJG(BLOC(I,J)) + END DO + END DO + + DO J = 1, LDA + DO I = 1, LDA + AB(I,J) = (0.0D0,0.0D0) + END DO + END DO + + IF (LEFT) THEN + DO J = 1, M + DO I = 1, M + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + DO K = 1, N + AB(I,J) = AB(I,J) - BB(I,K)*DCONJG(X(J,K)) + END DO + ELSE IF (IST) THEN + DO K = 1, N + AB(I,J) = AB(I,J) - DCONJG(X(I,K))*BB(J,K) + END DO + ELSE + DO K = 1, N + AB(I,J) = AB(I,J) - DCONJG(BB(J,K))*X(I,K) + END DO + END IF + END IF + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + DO K = 1, M + AB(I,J) = AB(I,J) - DCONJG(X(K,I))*BB(K,J) + END DO + ELSE IF (IST) THEN + DO K = 1, M + AB(I,J) = AB(I,J) - DCONJG(X(K,J))*BB(K,I) + END DO + ELSE + DO K = 1, M + AB(I,J) = AB(I,J) - X(K,J)*DCONJG(BB(K,I)) + END DO + END IF + END IF + END IF + END DO + END DO + END IF + + DO J = 1, N + DO I = 1, M + BB(I,J) = DCONJG(ALPHA)*BB(I,J) + END DO + END DO + + RETURN + END SUBROUTINE ZTRSM_B + diff --git a/BLAS/src/ztrsm_bv.f b/BLAS/src/ztrsm_bv.f new file mode 100644 index 0000000..0907c2d --- /dev/null +++ b/BLAS/src/ztrsm_bv.f @@ -0,0 +1,1244 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ztrsm in reverse (adjoint) mode (with options multiDirectional): +C gradient of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:out a:out b:in-out +C> \brief \b ZTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C COMPLEX*16 ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C COMPLEX*16 A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> ZTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**H. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is COMPLEX*16 +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX*16 array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is COMPLEX*16 array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE ZTRSM_BV(side, uplo, transa, diag, m, n, alpha, alphab +C + , a, ab, lda, b, bb, ldb, nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C COMPLEX*16 alpha +C COMPLEX*16 alphab(nbdirsmax) +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX*16 a(lda, *), b(ldb, *) +C COMPLEX*16 ab(nbdirsmax, lda, *), bb(nbdirsmax, ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC DCONJG, MAX +CC .. +CC .. Local Scalars .. +C COMPLEX*16 temp +C COMPLEX*16 tempb(nbdirsmax) +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, noconj, nounit, upper +C INTEGER ISIZE2OFA +CC .. +CC .. Parameters .. +C COMPLEX*16 zero +C PARAMETER (zero=(0.0d+0,0.0d+0)) +C INTEGER max1 +C INTEGER max2 +C INTEGER nd +C COMPLEX*16 tempb0(nbdirsmax) +C COMPLEX*16 tmp +C COMPLEX*16 tmpb(nbdirsmax) +C COMPLEX*16 tmp0 +C COMPLEX*16 tmpb0(nbdirsmax) +C DOUBLE COMPLEX temp0 +C COMPLEX*16 tmp1 +C COMPLEX*16 tmpb1(nbdirsmax) +C COMPLEX*16 tmp2 +C COMPLEX*16 tmpb2(nbdirsmax) +C COMPLEX*16 tmp3 +C COMPLEX*16 tmpb3(nbdirsmax) +C COMPLEX*16 tmp4 +C COMPLEX*16 tmpb4(nbdirsmax) +C INTEGER ad_to +C INTEGER*4 branch +C INTEGER ad_from +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_to2 +C INTEGER ad_from2 +C INTEGER ad_to3 +C INTEGER ad_from3 +C INTEGER ii2 +C INTEGER ii1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C noconj = LSAME(transa, 'T') +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE IF (m .LT. 0) THEN +C CALL PUSHCONTROL3B(4) +C info = 5 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(6) +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) THEN +C CALL PUSHCONTROL3B(7) +C info = 11 +C ELSE +C CALL PUSHCONTROL3B(7) +C END IF +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (m .EQ. 0 .OR. n .EQ. 0) THEN +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=n,1,-1 +C DO i=m,1,-1 +C DO nd=1,nbdirs +C bb(nd, i, j) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C ELSE IF (lside) THEN +CC +CC Start the operations. +CC +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,k-1 +C tmp = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=1,m,1 +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tmpb(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb(nd) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-a(i, k))*tmpb +C + (nd) +C ab(nd, i, k) = ab(nd, i, k) + CONJG(-b(k, j))*tmpb +C + (nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPCOMPLEX16(b(k, j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(k, k))*bb(nd, k, j) +C bb(nd, k, j) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) + CONJG(-(b(k, j)/a(k +C + , k)))*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*bb(nd, i, j +C + ) +C bb(nd, i, j) = CONJG(alpha)*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(b(k, j)) +C b(k, j) = b(k, j)/a(k, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCONTROL1B(0) +C END IF +C ad_from = k + 1 +C DO i=ad_from,m +C tmp0 = b(i, j) - b(k, j)*a(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp0 +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO k=m,1,-1 +C CALL POPINTEGER4(ad_from) +C DO i=m,ad_from,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tmpb0(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb0(nd) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-a(i, k))* +C + tmpb0(nd) +C ab(nd, i, k) = ab(nd, i, k) + CONJG(-b(k, j))* +C + tmpb0(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .NE. 0) THEN +C CALL POPCOMPLEX16(b(k, j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(k, k))*bb(nd, k, j) +C bb(nd, k, j) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) + CONJG(-(b(k, j)/a(k +C + , k)))*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*bb(nd, i, j +C + ) +C bb(nd, i, j) = CONJG(alpha)*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B +CC or B := alpha*inv( A**H )*B. +CC +C DO j=1,n +C DO i=1,m +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=1,i-1 +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO k=1,i-1 +C temp = temp - DCONJG(a(k, i))*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(i, i)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tempb(nd) = bb(nd, i, j) +C bb(nd, i, j) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, i, i) = ab(nd, i, i) + CONJG(-(temp/a(i, i) +C + ))*tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to0) +C DO k=ad_to0,1,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) + CONJG(-b(k, j))* +C + tempb(nd) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-a(k, i))* +C + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(i, i)) +C DO nd=1,nbdirs +C ab(nd, i, i) = ab(nd, i, i) + DCONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO k=ad_to1,1,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) + DCONJG(CONJG(-b(k, j +C + ))*tempb(nd)) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-DCONJG(a(k, i +C + )))*tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*tempb(nd) +C bb(nd, i, j) = bb(nd, i, j) + CONJG(alpha)*tempb(nd) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C temp = alpha*b(i, j) +C IF (noconj) THEN +C ad_from0 = i + 1 +C DO k=ad_from0,m +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(i, i) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C ad_from1 = i + 1 +C DO k=ad_from1,m +C temp = temp - DCONJG(a(k, i))*b(k, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(i, i)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = temp +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO i=1,m,1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tempb(nd) = bb(nd, i, j) +C bb(nd, i, j) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, i, i) = ab(nd, i, i) + CONJG(-(temp/a(i, i) +C + ))*tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from0) +C DO k=m,ad_from0,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) + CONJG(-b(k, j))* +C + tempb(nd) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-a(k, i))* +C + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(i, i)) +C DO nd=1,nbdirs +C ab(nd, i, i) = ab(nd, i, i) + DCONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from1) +C DO k=m,ad_from1,-1 +C DO nd=1,nbdirs +C ab(nd, k, i) = ab(nd, k, i) + DCONJG(CONJG(-b(k, j +C + ))*tempb(nd)) +C bb(nd, k, j) = bb(nd, k, j) + CONJG(-DCONJG(a(k, i +C + )))*tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*tempb(nd) +C bb(nd, i, j) = bb(nd, i, j) + CONJG(alpha)*tempb(nd) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C tmp1 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp1 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(k - 1) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*bb(nd, i, j) +C bb(nd, i, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(b(i, j)/a(j, j +C + )))*tempb0(nd) +C ENDDO +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to2) +C DO k=ad_to2,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tmpb1(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb1(nd) +C ab(nd, k, j) = ab(nd, k, j) + CONJG(-b(i, k))*tmpb1( +C + nd) +C bb(nd, i, k) = bb(nd, i, k) + CONJG(-a(k, j))*tmpb1( +C + nd) +C ENDDO +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*bb(nd, i, j) +C bb(nd, i, j) = CONJG(alpha)*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = alpha*b(i, j) +C ENDDO +C ad_from2 = j + 1 +C DO k=ad_from2,n +C DO i=1,m +C tmp2 = b(i, j) - a(k, j)*b(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp2 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C IF (nounit) THEN +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = b(i, j)/a(j, j) +C ENDDO +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*bb(nd, i, j) +C bb(nd, i, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(b(i, j)/a(j, j +C + )))*tempb0(nd) +C ENDDO +C ENDDO +C END IF +C CALL POPINTEGER4(ad_from2) +C DO k=n,ad_from2,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tmpb2(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb2(nd) +C ab(nd, k, j) = ab(nd, k, j) + CONJG(-b(i, k))*tmpb2( +C + nd) +C bb(nd, i, k) = bb(nd, i, k) + CONJG(-a(k, j))*tmpb2( +C + nd) +C ENDDO +C ENDDO +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, j))*bb(nd, i, j) +C bb(nd, i, j) = CONJG(alpha)*bb(nd, i, j) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ) +CC or B := alpha*B*inv( A**H ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL2B(2) +C ELSE +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = b(i, k)/DCONJG(a(k, k)) +C ENDDO +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C CALL PUSHCONTROL2B(0) +C END IF +C DO j=1,k-1 +C IF (noconj) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = a(j, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCOMPLEX16(temp) +C temp = DCONJG(a(j, k)) +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,m +C tmp3 = b(i, j) - temp*b(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp3 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(j - 1) +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO k=1,n,1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, k))*bb(nd, i, k) +C bb(nd, i, k) = CONJG(alpha)*bb(nd, i, k) +C ENDDO +C ENDDO +C CALL POPINTEGER4(ad_to3) +C DO j=ad_to3,1,-1 +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tmpb3(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb3(nd) +C tempb(nd) = tempb(nd) + CONJG(-b(i, k))*tmpb3(nd) +C bb(nd, i, k) = bb(nd, i, k) + CONJG(-temp)*tmpb3(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C ab(nd, j, k) = ab(nd, j, k) + DCONJG(tempb(nd)) +C ENDDO +C ELSE +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C ab(nd, j, k) = ab(nd, j, k) + tempb(nd) +C ENDDO +C END IF +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .NE. 0) THEN +C IF (branch .EQ. 1) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C temp0 = DCONJG(a(k, k)) +C DO nd=1,nbdirs +C ab(nd, k, k) = ab(nd, k, k) + DCONJG(CONJG(-(b(i, k) +C + /temp0**2))*bb(nd, i, k)) +C bb(nd, i, k) = CONJG(1.0/temp0)*bb(nd, i, k) +C ENDDO +C ENDDO +C ELSE +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(k, k))*bb(nd, i, k) +C bb(nd, i, k) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) + CONJG(-(b(i, k)/a(k, k +C + )))*tempb0(nd) +C ENDDO +C ENDDO +C END IF +C END IF +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = b(i, k)/a(k, k) +C ENDDO +C CALL PUSHCONTROL2B(2) +C ELSE +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = b(i, k)/DCONJG(a(k, k)) +C ENDDO +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C CALL PUSHCONTROL2B(0) +C END IF +C ad_from3 = k + 1 +C DO j=ad_from3,n +C IF (noconj) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = a(j, k) +C CALL PUSHCONTROL1B(1) +C ELSE +C CALL PUSHCOMPLEX16(temp) +C temp = DCONJG(a(j, k)) +C CALL PUSHCONTROL1B(0) +C END IF +C DO i=1,m +C tmp4 = b(i, j) - temp*b(i, k) +C CALL PUSHCOMPLEX16(b(i, j)) +C b(i, j) = tmp4 +C ENDDO +C ENDDO +C CALL PUSHINTEGER4(ad_from3) +C DO i=1,m +C CALL PUSHCOMPLEX16(b(i, k)) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C DO nd=1,nbdirsmax +C alphab(nd) = (0.0,0.0) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO k=n,1,-1 +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C DO nd=1,nbdirs +C alphab(nd) = alphab(nd) + CONJG(b(i, k))*bb(nd, i, k) +C bb(nd, i, k) = CONJG(alpha)*bb(nd, i, k) +C ENDDO +C ENDDO +C CALL POPINTEGER4(ad_from3) +C DO j=n,ad_from3,-1 +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, j)) +C DO nd=1,nbdirs +C tmpb4(nd) = bb(nd, i, j) +C bb(nd, i, j) = tmpb4(nd) +C tempb(nd) = tempb(nd) + CONJG(-b(i, k))*tmpb4(nd) +C bb(nd, i, k) = bb(nd, i, k) + CONJG(-temp)*tmpb4(nd) +C ENDDO +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C ab(nd, j, k) = ab(nd, j, k) + DCONJG(tempb(nd)) +C ENDDO +C ELSE +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C ab(nd, j, k) = ab(nd, j, k) + tempb(nd) +C ENDDO +C END IF +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .NE. 0) THEN +C IF (branch .EQ. 1) THEN +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C temp0 = DCONJG(a(k, k)) +C DO nd=1,nbdirs +C ab(nd, k, k) = ab(nd, k, k) + DCONJG(CONJG(-(b(i, k) +C + /temp0**2))*bb(nd, i, k)) +C bb(nd, i, k) = CONJG(1.0/temp0)*bb(nd, i, k) +C ENDDO +C ENDDO +C ELSE +C DO i=m,1,-1 +C CALL POPCOMPLEX16(b(i, k)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(k, k))*bb(nd, i, k) +C bb(nd, i, k) = tempb0(nd) +C ab(nd, k, k) = ab(nd, k, k) + CONJG(-(b(i, k)/a(k, k +C + )))*tempb0(nd) +C ENDDO +C ENDDO +C END IF +C END IF +C ENDDO +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE ZTRSM_BV(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB, NBDIRS) + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB, NBDIRS + COMPLEX*16 ALPHA + COMPLEX*16 ALPHAB(NBDIRSMAX) + COMPLEX*16 A(LDA,*), AB(NBDIRSMAX,LDA,*) + COMPLEX*16 B(LDB,*), BB(NBDIRSMAX,LDB,*) + + COMPLEX*16 X(M,N), BLOC(M,N) + COMPLEX*16 AB_SLICE(LDA,LDA), BB_SLICE(LDB,N) + LOGICAL LEFT, UPPER, UNIT, ISN, IST, ISC + INTEGER ND, I, J, K + INTRINSIC DCONJG + + LEFT = (SIDE.EQ.'L' .OR. SIDE.EQ.'l') + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + ISN = (TRANSA.EQ.'N' .OR. TRANSA.EQ.'n') + IST = (TRANSA.EQ.'T' .OR. TRANSA.EQ.'t') + ISC = (TRANSA.EQ.'C' .OR. TRANSA.EQ.'c') + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (M.EQ.0 .OR. N.EQ.0) THEN + DO ND = 1, NBDIRS + ALPHAB(ND) = (0.0D0,0.0D0) + END DO + RETURN + END IF + + DO J = 1, N + DO I = 1, M + BLOC(I,J) = B(I,J) + END DO + END DO + DO J = 1, N + DO I = 1, M + X(I,J) = BLOC(I,J) + END DO + END DO + CALL ZTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO ND = 1, NBDIRS + + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = BB(ND,I,J) + END DO + END DO + + IF (ISN) THEN + CALL ZTRSM(SIDE, UPLO, 'C', DIAG, M, N, (1.0D0,0.0D0), + + A, LDA, BB_SLICE, LDB) + ELSE IF (ISC) THEN + CALL ZTRSM(SIDE, UPLO, 'N', DIAG, M, N, (1.0D0,0.0D0), + + A, LDA, BB_SLICE, LDB) + ELSE + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = DCONJG(BB_SLICE(I,J)) + END DO + END DO + CALL ZTRSM(SIDE, UPLO, 'N', DIAG, M, N, (1.0D0,0.0D0), + + A, LDA, BB_SLICE, LDB) + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = DCONJG(BB_SLICE(I,J)) + END DO + END DO + END IF + + ALPHAB(ND) = (0.0D0,0.0D0) + DO J = 1, N + DO I = 1, M + ALPHAB(ND) = ALPHAB(ND) + BB_SLICE(I,J)*DCONJG(BLOC(I,J)) + END DO + END DO + + DO J = 1, LDA + DO I = 1, LDA + AB_SLICE(I,J) = (0.0D0,0.0D0) + END DO + END DO + + IF (LEFT) THEN + DO J = 1, M + DO I = 1, M + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - BB_SLICE(I,K)*DCONJG(X(J,K)) + END DO + ELSE IF (IST) THEN + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - DCONJG(X(I,K))*BB_SLICE(J,K) + END DO + ELSE + DO K = 1, N + AB_SLICE(I,J) = AB_SLICE(I,J) + + - DCONJG(BB_SLICE(J,K))*X(I,K) + END DO + END IF + END IF + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - DCONJG(X(K,I))*BB_SLICE(K,J) + END DO + ELSE IF (IST) THEN + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - DCONJG(X(K,J))*BB_SLICE(K,I) + END DO + ELSE + DO K = 1, M + AB_SLICE(I,J) = AB_SLICE(I,J) + + - X(K,J)*DCONJG(BB_SLICE(K,I)) + END DO + END IF + END IF + END IF + END DO + END DO + END IF + + DO J = 1, N + DO I = 1, M + BB_SLICE(I,J) = DCONJG(ALPHA)*BB_SLICE(I,J) + END DO + END DO + + DO J = 1, N + DO I = 1, M + BB(ND,I,J) = BB_SLICE(I,J) + END DO + END DO + DO J = 1, LDA + DO I = 1, LDA + AB(ND,I,J) = AB_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE ZTRSM_BV + diff --git a/BLAS/src/ztrsm_d.f b/BLAS/src/ztrsm_d.f new file mode 100644 index 0000000..63859f9 --- /dev/null +++ b/BLAS/src/ztrsm_d.f @@ -0,0 +1,583 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ztrsm in forward (tangent) mode: +C variations of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:in a:in b:in-out +C> \brief \b ZTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C COMPLEX*16 ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C COMPLEX*16 A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> ZTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**H. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is COMPLEX*16 +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX*16 array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is COMPLEX*16 array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE ZTRSM_D(side, uplo, transa, diag, m, n, alpha, alphad, +C + a, ad, lda, b, bd, ldb) +C IMPLICIT NONE +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C COMPLEX*16 alpha +C COMPLEX*16 alphad +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX*16 a(lda, *), b(ldb, *) +C COMPLEX*16 ad(lda, *), bd(ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC DCONJG, MAX +CC .. +CC .. Local Scalars .. +C COMPLEX*16 temp +C COMPLEX*16 tempd +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, noconj, nounit, upper +CC .. +CC .. Parameters .. +C COMPLEX*16 zero +C PARAMETER (zero=(0.0d+0,0.0d+0)) +C INTEGER max1 +C INTEGER max2 +C COMPLEX*16 temp0 +C DOUBLE COMPLEX temp1 +CC .. +CC +CC Test the input parameters. +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C noconj = LSAME(transa, 'T') +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 4 +C ELSE IF (m .LT. 0) THEN +C info = 5 +C ELSE IF (n .LT. 0) THEN +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) info = 11 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('ZTRSM ', info) +C RETURN +C ELSE IF (m .EQ. 0 .OR. n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=1,n +C DO i=1,m +C bd(i, j) = 0.0 +C b(i, j) = zero +C ENDDO +C ENDDO +C RETURN +C ELSE +CC +CC Start the operations. +CC +C IF (lside) THEN +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C bd(k, j) = (bd(k, j)-temp0*ad(k, k))/a(k, k) +C b(k, j) = temp0 +C END IF +C DO i=1,k-1 +C bd(i, j) = bd(i, j) - a(i, k)*bd(k, j) - b(k, j)*ad( +C + i, k) +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C bd(k, j) = (bd(k, j)-temp0*ad(k, k))/a(k, k) +C b(k, j) = temp0 +C END IF +C DO i=k+1,m +C bd(i, j) = bd(i, j) - a(i, k)*bd(k, j) - b(k, j)*ad( +C + i, k) +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B +CC or B := alpha*inv( A**H )*B. +CC +C DO j=1,n +C DO i=1,m +C tempd = b(i, j)*alphad + alpha*bd(i, j) +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=1,i-1 +C tempd = tempd - b(k, j)*ad(k, i) - a(k, i)*bd(k, j) +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C tempd = (tempd-temp0*ad(i, i))/a(i, i) +C temp = temp0 +C END IF +C ELSE +C DO k=1,i-1 +C temp1 = DCONJG(a(k, i)) +C tempd = tempd - b(k, j)*DCONJG(ad(k, i)) - temp1*bd( +C + k, j) +C temp = temp - temp1*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(i, i)) +C tempd = (tempd-temp*DCONJG(ad(i, i))/temp1)/temp1 +C temp = temp/temp1 +C END IF +C END IF +C bd(i, j) = tempd +C b(i, j) = temp +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C tempd = b(i, j)*alphad + alpha*bd(i, j) +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=i+1,m +C tempd = tempd - b(k, j)*ad(k, i) - a(k, i)*bd(k, j) +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C tempd = (tempd-temp0*ad(i, i))/a(i, i) +C temp = temp0 +C END IF +C ELSE +C DO k=i+1,m +C temp1 = DCONJG(a(k, i)) +C tempd = tempd - b(k, j)*DCONJG(ad(k, i)) - temp1*bd( +C + k, j) +C temp = temp - temp1*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(i, i)) +C tempd = (tempd-temp*DCONJG(ad(i, i))/temp1)/temp1 +C temp = temp/temp1 +C END IF +C END IF +C bd(i, j) = tempd +C b(i, j) = temp +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(k, j) - a(k, j)*bd(i +C + , k) +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C bd(i, j) = (bd(i, j)-temp0*ad(j, j))/a(j, j) +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C bd(i, j) = b(i, j)*alphad + alpha*bd(i, j) +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=j+1,n +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*ad(k, j) - a(k, j)*bd(i +C + , k) +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C bd(i, j) = (bd(i, j)-temp0*ad(j, j))/a(j, j) +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ) +CC or B := alpha*B*inv( A**H ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C bd(i, k) = (bd(i, k)-temp0*ad(k, k))/a(k, k) +C b(i, k) = temp0 +C ENDDO +C ELSE +C DO i=1,m +C temp1 = DCONJG(a(k, k)) +C temp0 = b(i, k)/temp1 +C bd(i, k) = (bd(i, k)-temp0*DCONJG(ad(k, k)))/temp1 +C b(i, k) = temp0 +C ENDDO +C END IF +C END IF +C DO j=1,k-1 +C IF (noconj) THEN +C tempd = ad(j, k) +C temp = a(j, k) +C ELSE +C tempd = DCONJG(ad(j, k)) +C temp = DCONJG(a(j, k)) +C END IF +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*tempd - temp*bd(i, k) +C b(i, j) = b(i, j) - temp*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C bd(i, k) = b(i, k)*alphad + alpha*bd(i, k) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C bd(i, k) = (bd(i, k)-temp0*ad(k, k))/a(k, k) +C b(i, k) = temp0 +C ENDDO +C ELSE +C DO i=1,m +C temp1 = DCONJG(a(k, k)) +C temp0 = b(i, k)/temp1 +C bd(i, k) = (bd(i, k)-temp0*DCONJG(ad(k, k)))/temp1 +C b(i, k) = temp0 +C ENDDO +C END IF +C END IF +C DO j=k+1,n +C IF (noconj) THEN +C tempd = ad(j, k) +C temp = a(j, k) +C ELSE +C tempd = DCONJG(ad(j, k)) +C temp = DCONJG(a(j, k)) +C END IF +C DO i=1,m +C bd(i, j) = bd(i, j) - b(i, k)*tempd - temp*bd(i, k) +C b(i, j) = b(i, j) - temp*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C bd(i, k) = b(i, k)*alphad + alpha*bd(i, k) +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C END IF +CC +C RETURN +CC +CC End of ZTRSM +CC +C END IF +C END + + SUBROUTINE ZTRSM_D(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB) + IMPLICIT NONE + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + COMPLEX*16 ALPHA, ALPHAD + COMPLEX*16 A(LDA,*), AD(LDA,*) + COMPLEX*16 B(LDB,*), BD(LDB,*) + + COMPLEX*16 X(M,N), T(M,N) + INTEGER I, J + + IF (M.EQ.0 .OR. N.EQ.0) RETURN + + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL ZTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO J = 1, N + DO I = 1, M + T(I,J) = X(I,J) + END DO + END DO + CALL ZTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, (1.0D0,0.0D0), + + AD, LDA, T, M) + + DO J = 1, N + DO I = 1, M + BD(I,J) = ALPHAD*B(I,J) + ALPHA*BD(I,J) - T(I,J) + END DO + END DO + + CALL ZTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, (1.0D0,0.0D0), + + A, LDA, BD, LDB) + + RETURN + END SUBROUTINE ZTRSM_D + diff --git a/BLAS/src/ztrsm_dv.f b/BLAS/src/ztrsm_dv.f new file mode 100644 index 0000000..1073c7f --- /dev/null +++ b/BLAS/src/ztrsm_dv.f @@ -0,0 +1,711 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ztrsm in forward (tangent) mode (with options multiDirectional): +C variations of useful results: b +C with respect to varying inputs: alpha a b +C RW status of diff variables: alpha:in a:in b:in-out +C> \brief \b ZTRSM +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +C +C .. Scalar Arguments .. +C COMPLEX*16 ALPHA +C INTEGER LDA,LDB,M,N +C CHARACTER DIAG,SIDE,TRANSA,UPLO +C .. +C .. Array Arguments .. +C COMPLEX*16 A(LDA,*),B(LDB,*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> ZTRSM solves one of the matrix equations +C> +C> op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C> +C> where alpha is a scalar, X and B are m by n matrices, A is a unit, or +C> non-unit, upper or lower triangular matrix and op( A ) is one of +C> +C> op( A ) = A or op( A ) = A**T or op( A ) = A**H. +C> +C> The matrix X is overwritten on B. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] SIDE +C> \verbatim +C> SIDE is CHARACTER*1 +C> On entry, SIDE specifies whether op( A ) appears on the left +C> or right of X as follows: +C> +C> SIDE = 'L' or 'l' op( A )*X = alpha*B. +C> +C> SIDE = 'R' or 'r' X*op( A ) = alpha*B. +C> \endverbatim +C> +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix A is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANSA +C> \verbatim +C> TRANSA is CHARACTER*1 +C> On entry, TRANSA specifies the form of op( A ) to be used in +C> the matrix multiplication as follows: +C> +C> TRANSA = 'N' or 'n' op( A ) = A. +C> +C> TRANSA = 'T' or 't' op( A ) = A**T. +C> +C> TRANSA = 'C' or 'c' op( A ) = A**H. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit triangular +C> as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] M +C> \verbatim +C> M is INTEGER +C> On entry, M specifies the number of rows of B. M must be at +C> least zero. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the number of columns of B. N must be +C> at least zero. +C> \endverbatim +C> +C> \param[in] ALPHA +C> \verbatim +C> ALPHA is COMPLEX*16 +C> On entry, ALPHA specifies the scalar alpha. When alpha is +C> zero then A is not referenced and B need not be set before +C> entry. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX*16 array, dimension ( LDA, k ), +C> where k is m when SIDE = 'L' or 'l' +C> and k is n when SIDE = 'R' or 'r'. +C> Before entry with UPLO = 'U' or 'u', the leading k by k +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading k by k +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. When SIDE = 'L' or 'l' then +C> LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +C> then LDA must be at least max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] B +C> \verbatim +C> B is COMPLEX*16 array, dimension ( LDB, N ) +C> Before entry, the leading m by n part of the array B must +C> contain the right-hand side matrix B, and on exit is +C> overwritten by the solution matrix X. +C> \endverbatim +C> +C> \param[in] LDB +C> \verbatim +C> LDB is INTEGER +C> On entry, LDB specifies the first dimension of B as declared +C> in the calling (sub) program. LDB must be at least +C> max( 1, m ). +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsm +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 3 Blas routine. +C> +C> -- Written on 8-February-1989. +C> Jack Dongarra, Argonne National Laboratory. +C> Iain Duff, AERE Harwell. +C> Jeremy Du Croz, Numerical Algorithms Group Ltd. +C> Sven Hammarling, Numerical Algorithms Group Ltd. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE ZTRSM_DV(side, uplo, transa, diag, m, n, alpha, alphad +C + , a, ad, lda, b, bd, ldb, nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level3 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C COMPLEX*16 alpha +C COMPLEX*16 alphad(nbdirsmax) +C INTEGER lda, ldb, m, n +C CHARACTER diag, side, transa, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX*16 a(lda, *), b(ldb, *) +C COMPLEX*16 ad(nbdirsmax, lda, *), bd(nbdirsmax, ldb, *) +C EXTERNAL LSAME +CC .. +CC +CC ===================================================================== +CC +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC DCONJG, MAX +CC .. +CC .. Local Scalars .. +C COMPLEX*16 temp +C COMPLEX*16 tempd(nbdirsmax) +C INTEGER i, info, j, k, nrowa +C LOGICAL lside, noconj, nounit, upper +CC .. +CC .. Parameters .. +C COMPLEX*16 zero +C PARAMETER (zero=(0.0d+0,0.0d+0)) +C INTEGER max1 +C INTEGER max2 +C INTEGER nd +C COMPLEX*16 temp0 +C DOUBLE COMPLEX temp1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C lside = LSAME(side, 'L') +C IF (lside) THEN +C nrowa = m +C ELSE +C nrowa = n +C END IF +C noconj = LSAME(transa, 'T') +C nounit = LSAME(diag, 'N') +C upper = LSAME(uplo, 'U') +CC +C info = 0 +C IF (.NOT.lside .AND. (.NOT.LSAME(side, 'R'))) THEN +C info = 1 +C ELSE IF (.NOT.upper .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(transa, 'N') .AND. (.NOT.LSAME(transa, 'T')) +C + .AND. (.NOT.LSAME(transa, 'C'))) THEN +C info = 3 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 4 +C ELSE IF (m .LT. 0) THEN +C info = 5 +C ELSE IF (n .LT. 0) THEN +C info = 6 +C ELSE +C IF (1 .LT. nrowa) THEN +C max1 = nrowa +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 9 +C ELSE +C IF (1 .LT. m) THEN +C max2 = m +C ELSE +C max2 = 1 +C END IF +C IF (ldb .LT. max2) info = 11 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('ZTRSM ', info) +C RETURN +C ELSE IF (m .EQ. 0 .OR. n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE IF (alpha .EQ. zero) THEN +CC +CC And when alpha.eq.zero. +CC +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = 0.0 +C ENDDO +C b(i, j) = zero +C ENDDO +C ENDDO +C RETURN +C ELSE +CC +CC Start the operations. +CC +C IF (lside) THEN +C IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*inv( A )*B. +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, +C + j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=m,1,-1 +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, k, j) = (bd(nd, k, j)-temp0*ad(nd, k, k))/a +C + (k, k) +C ENDDO +C b(k, j) = temp0 +C END IF +C DO i=1,k-1 +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - a(i, k)*bd(nd, k, j) +C + - b(k, j)*ad(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, +C + j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,m +C IF (nounit) THEN +C temp0 = b(k, j)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, k, j) = (bd(nd, k, j)-temp0*ad(nd, k, k))/a +C + (k, k) +C ENDDO +C b(k, j) = temp0 +C END IF +C DO i=k+1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - a(i, k)*bd(nd, k, j) +C + - b(k, j)*ad(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - b(k, j)*a(i, k) +C ENDDO +C ENDDO +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*inv( A**T )*B +CC or B := alpha*inv( A**H )*B. +CC +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C tempd(nd) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=1,i-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*ad(nd, k, i) - a(k +C + , i)*bd(nd, k, j) +C ENDDO +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, i, i))/a(i, i) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO k=1,i-1 +C temp1 = DCONJG(a(k, i)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*DCONJG(ad(nd, k, i +C + )) - temp1*bd(nd, k, j) +C ENDDO +C temp = temp - temp1*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(i, i)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*DCONJG(ad(nd, i, i))/ +C + temp1)/temp1 +C ENDDO +C temp = temp/temp1 +C END IF +C END IF +C DO nd=1,nbdirs +C bd(nd, i, j) = tempd(nd) +C ENDDO +C b(i, j) = temp +C ENDDO +C ENDDO +C ELSE +C DO j=1,n +C DO i=m,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C temp = alpha*b(i, j) +C IF (noconj) THEN +C DO k=i+1,m +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*ad(nd, k, i) - a(k +C + , i)*bd(nd, k, j) +C ENDDO +C temp = temp - a(k, i)*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(i, i) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, i, i))/a(i, i) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO k=i+1,m +C temp1 = DCONJG(a(k, i)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - b(k, j)*DCONJG(ad(nd, k, i +C + )) - temp1*bd(nd, k, j) +C ENDDO +C temp = temp - temp1*b(k, j) +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(i, i)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*DCONJG(ad(nd, i, i))/ +C + temp1)/temp1 +C ENDDO +C temp = temp/temp1 +C END IF +C END IF +C DO nd=1,nbdirs +C bd(nd, i, j) = tempd(nd) +C ENDDO +C b(i, j) = temp +C ENDDO +C ENDDO +C END IF +C ELSE IF (LSAME(transa, 'N')) THEN +CC +CC Form B := alpha*B*inv( A ). +CC +C IF (upper) THEN +C DO j=1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=1,j-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, k, j) - +C + a(k, j)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C DO nd=1,nbdirs +C bd(nd, i, j) = (bd(nd, i, j)-temp0*ad(nd, j, j))/a(j +C + , j) +C ENDDO +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C ELSE +C DO j=n,1,-1 +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = b(i, j)*alphad(nd) + alpha*bd(nd, i, j) +C ENDDO +C b(i, j) = alpha*b(i, j) +C ENDDO +C DO k=j+1,n +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*ad(nd, k, j) - +C + a(k, j)*bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - a(k, j)*b(i, k) +C ENDDO +C ENDDO +C IF (nounit) THEN +C DO i=1,m +C temp0 = b(i, j)/a(j, j) +C DO nd=1,nbdirs +C bd(nd, i, j) = (bd(nd, i, j)-temp0*ad(nd, j, j))/a(j +C + , j) +C ENDDO +C b(i, j) = temp0 +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (upper) THEN +CC +CC Form B := alpha*B*inv( A**T ) +CC or B := alpha*B*inv( A**H ). +CC +C DO k=n,1,-1 +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*ad(nd, k, k))/a(k +C + , k) +C ENDDO +C b(i, k) = temp0 +C ENDDO +C ELSE +C DO i=1,m +C temp1 = DCONJG(a(k, k)) +C temp0 = b(i, k)/temp1 +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*DCONJG(ad(nd, k, +C + k)))/temp1 +C ENDDO +C b(i, k) = temp0 +C ENDDO +C END IF +C END IF +C DO j=1,k-1 +C IF (noconj) THEN +C DO nd=1,nbdirs +C tempd(nd) = ad(nd, j, k) +C ENDDO +C temp = a(j, k) +C ELSE +C DO nd=1,nbdirs +C tempd(nd) = DCONJG(ad(nd, j, k)) +C ENDDO +C temp = DCONJG(a(j, k)) +C END IF +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*tempd(nd) - temp +C + *bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - temp*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, k) = b(i, k)*alphad(nd) + alpha*bd(nd, i, k) +C ENDDO +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C ELSE +C DO k=1,n +C IF (nounit) THEN +C IF (noconj) THEN +C DO i=1,m +C temp0 = b(i, k)/a(k, k) +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*ad(nd, k, k))/a(k +C + , k) +C ENDDO +C b(i, k) = temp0 +C ENDDO +C ELSE +C DO i=1,m +C temp1 = DCONJG(a(k, k)) +C temp0 = b(i, k)/temp1 +C DO nd=1,nbdirs +C bd(nd, i, k) = (bd(nd, i, k)-temp0*DCONJG(ad(nd, k, +C + k)))/temp1 +C ENDDO +C b(i, k) = temp0 +C ENDDO +C END IF +C END IF +C DO j=k+1,n +C IF (noconj) THEN +C DO nd=1,nbdirs +C tempd(nd) = ad(nd, j, k) +C ENDDO +C temp = a(j, k) +C ELSE +C DO nd=1,nbdirs +C tempd(nd) = DCONJG(ad(nd, j, k)) +C ENDDO +C temp = DCONJG(a(j, k)) +C END IF +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, j) = bd(nd, i, j) - b(i, k)*tempd(nd) - temp +C + *bd(nd, i, k) +C ENDDO +C b(i, j) = b(i, j) - temp*b(i, k) +C ENDDO +C ENDDO +C DO i=1,m +C DO nd=1,nbdirs +C bd(nd, i, k) = b(i, k)*alphad(nd) + alpha*bd(nd, i, k) +C ENDDO +C b(i, k) = alpha*b(i, k) +C ENDDO +C ENDDO +C END IF +CC +C RETURN +CC +CC End of ZTRSM +CC +C END IF +C END + + SUBROUTINE ZTRSM_DV(SIDE, UPLO, TRANSA, DIAG, M, N, + + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB, NBDIRS) + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB, NBDIRS + COMPLEX*16 ALPHA + COMPLEX*16 ALPHAD(NBDIRSMAX) + COMPLEX*16 A(LDA,*), AD(NBDIRSMAX,LDA,*) + COMPLEX*16 B(LDB,*), BD(NBDIRSMAX,LDB,*) + + COMPLEX*16 X(M,N), T(M,N) + COMPLEX*16 AD_SLICE(LDA,LDA), BD_SLICE(LDB,N) + INTEGER ND, I, J + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (M.EQ.0 .OR. N.EQ.0) RETURN + + DO J = 1, N + DO I = 1, M + X(I,J) = B(I,J) + END DO + END DO + CALL ZTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, X, M) + + DO ND = 1, NBDIRS + + DO J = 1, N + DO I = 1, M + AD_SLICE(I,J) = AD(ND,I,J) + BD_SLICE(I,J) = BD(ND,I,J) + END DO + END DO + + DO J = 1, N + DO I = 1, M + T(I,J) = X(I,J) + END DO + END DO + CALL ZTRMM(SIDE, UPLO, TRANSA, DIAG, M, N, (1.0D0,0.0D0), + + AD_SLICE, LDA, T, M) + + DO J = 1, N + DO I = 1, M + BD_SLICE(I,J) = ALPHAD(ND)*B(I,J) + ALPHA*BD_SLICE(I,J) + + - T(I,J) + END DO + END DO + + CALL ZTRSM(SIDE, UPLO, TRANSA, DIAG, M, N, (1.0D0,0.0D0), + + A, LDA, BD_SLICE, LDB) + + DO J = 1, N + DO I = 1, M + BD(ND,I,J) = BD_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE ZTRSM_DV + diff --git a/BLAS/src/ztrsv_b.f b/BLAS/src/ztrsv_b.f new file mode 100644 index 0000000..340af32 --- /dev/null +++ b/BLAS/src/ztrsv_b.f @@ -0,0 +1,858 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ztrsv in reverse (adjoint) mode: +C gradient of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:out +C> \brief \b ZTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C COMPLEX*16 A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> ZTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, or A**H*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**H*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX*16 array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is COMPLEX*16 array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE ZTRSV_B(uplo, trans, diag, n, a, ab, lda, x, xb, incx) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX*16 a(lda, *), x(*) +C COMPLEX*16 ab(lda, *), xb(*) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C COMPLEX*16 temp +C COMPLEX*16 tempb +C INTEGER i, info, ix, j, jx, kx +C LOGICAL noconj, nounit +C EXTERNAL LSAME +C INTEGER ISIZE2OFA +CC .. +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC DCONJG, MAX +C INTEGER max1 +C COMPLEX*16 tempb0 +C DOUBLE COMPLEX temp0 +C INTEGER ad_from +C INTEGER*4 branch +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_from2 +C INTEGER ad_to +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_to2 +C INTEGER ad_to3 +C INTEGER ad_to4 +C INTEGER ad_to5 +C INTEGER ad_to6 +C INTEGER ii2 +C INTEGER ii1 +CC .. +CC +CC Test the input parameters. +CC +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(4) +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 8 +C ELSE +C CALL PUSHCONTROL3B(5) +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (n .EQ. 0) THEN +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ELSE +CC +C noconj = LSAME(trans, 'T') +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C CALL PUSHCONTROL1B(0) +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C CALL PUSHCONTROL1B(1) +C kx = 1 +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX16(temp) +C temp = x(j) +C ad_from = j - 1 +C DO i=ad_from,1,-1 +C CALL PUSHCOMPLEX16(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C tempb = (0.0,0.0) +C CALL POPINTEGER4(ad_from) +C DO i=1,ad_from,1 +C CALL POPCOMPLEX16(x(i)) +C tempb = tempb + CONJG(-a(i, j))*xb(i) +C ab(i, j) = ab(i, j) + CONJG(-temp)*xb(i) +C ENDDO +C CALL POPCOMPLEX16(temp) +C xb(j) = xb(j) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(x(j)) +C tempb0 = CONJG(1.0/a(j, j))*xb(j) +C xb(j) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(x(j)/a(j, j)))*tempb0 +C END IF +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX16(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from0 = j - 1 +C DO i=ad_from0,1,-1 +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C CALL PUSHCOMPLEX16(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C tempb = (0.0,0.0) +C CALL POPINTEGER4(ad_from0) +C DO i=1,ad_from0,1 +C CALL POPCOMPLEX16(x(ix)) +C tempb = tempb + CONJG(-a(i, j))*xb(ix) +C ab(i, j) = ab(i, j) + CONJG(-temp)*xb(ix) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPCOMPLEX16(temp) +C xb(jx) = xb(jx) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(x(jx)) +C tempb0 = CONJG(1.0/a(j, j))*xb(jx) +C xb(jx) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(x(jx)/a(j, j)))*tempb0 +C END IF +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX16(temp) +C temp = x(j) +C ad_from1 = j + 1 +C DO i=ad_from1,n +C CALL PUSHCOMPLEX16(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C tempb = (0.0,0.0) +C CALL POPINTEGER4(ad_from1) +C DO i=n,ad_from1,-1 +C CALL POPCOMPLEX16(x(i)) +C tempb = tempb + CONJG(-a(i, j))*xb(i) +C ab(i, j) = ab(i, j) + CONJG(-temp)*xb(i) +C ENDDO +C CALL POPCOMPLEX16(temp) +C xb(j) = xb(j) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(x(j)) +C tempb0 = CONJG(1.0/a(j, j))*xb(j) +C xb(j) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(x(j)/a(j, j)))*tempb0 +C END IF +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX16(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from2 = j + 1 +C DO i=ad_from2,n +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C CALL PUSHCOMPLEX16(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C tempb = (0.0,0.0) +C CALL POPINTEGER4(ad_from2) +C DO i=n,ad_from2,-1 +C CALL POPCOMPLEX16(x(ix)) +C tempb = tempb + CONJG(-a(i, j))*xb(ix) +C ab(i, j) = ab(i, j) + CONJG(-temp)*xb(ix) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPCOMPLEX16(temp) +C xb(jx) = xb(jx) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(x(jx)) +C tempb0 = CONJG(1.0/a(j, j))*xb(jx) +C xb(jx) = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(x(jx)/a(j, j)))*tempb0 +C END IF +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x or x := inv( A**H )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C temp = x(j) +C IF (noconj) THEN +C DO i=1,j-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=1,j-1 +C temp = temp - DCONJG(a(i, j))*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCOMPLEX16(x(j)) +C tempb = xb(j) +C xb(j) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C tempb0 = CONJG(1.0/a(j, j))*tempb +C tempb = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(temp/a(j, j)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C ab(i, j) = ab(i, j) + CONJG(-x(i))*tempb +C xb(i) = xb(i) + CONJG(-a(i, j))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(j, j)) +C ab(j, j) = ab(j, j) + DCONJG(CONJG(-(temp/temp0**2)) +C + *tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to0) +C DO i=ad_to0,1,-1 +C ab(i, j) = ab(i, j) + DCONJG(CONJG(-x(i))*tempb) +C xb(i) = xb(i) + CONJG(-DCONJG(a(i, j)))*tempb +C ENDDO +C END IF +C xb(j) = xb(j) + tempb +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C ix = kx +C temp = x(jx) +C IF (noconj) THEN +C DO i=1,j-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=1,j-1 +C temp = temp - DCONJG(a(i, j))*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C CALL POPCOMPLEX16(x(jx)) +C tempb = xb(jx) +C xb(jx) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C tempb0 = CONJG(1.0/a(j, j))*tempb +C tempb = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(temp/a(j, j)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to1) +C DO i=ad_to1,1,-1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) + CONJG(-x(ix))*tempb +C xb(ix) = xb(ix) + CONJG(-a(i, j))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(j, j)) +C ab(j, j) = ab(j, j) + DCONJG(CONJG(-(temp/temp0**2)) +C + *tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to2) +C DO i=ad_to2,1,-1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) + DCONJG(CONJG(-x(ix))*tempb) +C xb(ix) = xb(ix) + CONJG(-DCONJG(a(i, j)))*tempb +C ENDDO +C END IF +C xb(jx) = xb(jx) + tempb +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C temp = x(j) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp = temp - DCONJG(a(i, j))*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCOMPLEX16(x(j)) +C tempb = xb(j) +C xb(j) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C tempb0 = CONJG(1.0/a(j, j))*tempb +C tempb = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(temp/a(j, j)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to3) +C DO i=ad_to3,n,1 +C ab(i, j) = ab(i, j) + CONJG(-x(i))*tempb +C xb(i) = xb(i) + CONJG(-a(i, j))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(j, j)) +C ab(j, j) = ab(j, j) + DCONJG(CONJG(-(temp/temp0**2))* +C + tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to4) +C DO i=ad_to4,n,1 +C ab(i, j) = ab(i, j) + DCONJG(CONJG(-x(i))*tempb) +C xb(i) = xb(i) + CONJG(-DCONJG(a(i, j)))*tempb +C ENDDO +C END IF +C xb(j) = xb(j) + tempb +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C ix = kx +C temp = x(jx) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp = temp - DCONJG(a(i, j))*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C CALL POPCOMPLEX16(x(jx)) +C tempb = xb(jx) +C xb(jx) = (0.0,0.0) +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C tempb0 = CONJG(1.0/a(j, j))*tempb +C tempb = tempb0 +C ab(j, j) = ab(j, j) + CONJG(-(temp/a(j, j)))*tempb0 +C END IF +C CALL POPINTEGER4(ad_to5) +C DO i=ad_to5,n,1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) + CONJG(-x(ix))*tempb +C xb(ix) = xb(ix) + CONJG(-a(i, j))*tempb +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(j, j)) +C ab(j, j) = ab(j, j) + DCONJG(CONJG(-(temp/temp0**2))* +C + tempb) +C tempb = CONJG(1.0/temp0)*tempb +C END IF +C CALL POPINTEGER4(ad_to6) +C DO i=ad_to6,n,1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) + DCONJG(CONJG(-x(ix))*tempb) +C xb(ix) = xb(ix) + CONJG(-DCONJG(a(i, j)))*tempb +C ENDDO +C END IF +C xb(jx) = xb(jx) + tempb +C ENDDO +C END IF +C CALL POPCONTROL1B(branch) +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE ZTRSV_B(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, INCX) + IMPLICIT NONE + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX + COMPLEX*16 A(LDA,*), AB(LDA,*) + COMPLEX*16 X(*), XB(*) + + COMPLEX*16 BLOC(N), S(N), YB(N) + LOGICAL UPPER, UNIT, ISN, IST, ISC + INTEGER I, J, KX + INTRINSIC DCONJG + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + ISN = (TRANS.EQ.'N' .OR. TRANS.EQ.'n') + IST = (TRANS.EQ.'T' .OR. TRANS.EQ.'t') + ISC = (TRANS.EQ.'C' .OR. TRANS.EQ.'c') + + DO I = 1, N + BLOC(I) = X(KX + (I-1)*INCX) + YB(I) = XB(KX + (I-1)*INCX) + END DO + + IF (ISN) THEN + CALL ZTRSV(UPLO, 'C', DIAG, N, A, LDA, YB, 1) + ELSE IF (ISC) THEN + CALL ZTRSV(UPLO, 'N', DIAG, N, A, LDA, YB, 1) + ELSE + DO I = 1, N + YB(I) = DCONJG(YB(I)) + END DO + CALL ZTRSV(UPLO, 'N', DIAG, N, A, LDA, YB, 1) + DO I = 1, N + YB(I) = DCONJG(YB(I)) + END DO + END IF + + DO I = 1, N + S(I) = BLOC(I) + END DO + CALL ZTRSV(UPLO, TRANS, DIAG, N, A, LDA, S, 1) + + DO J = 1, LDA + DO I = 1, LDA + AB(I,J) = (0.0D0, 0.0D0) + END DO + END DO + + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + AB(I,J) = -YB(I)*DCONJG(S(J)) + ELSE IF (IST) THEN + AB(I,J) = -YB(J)*DCONJG(S(I)) + ELSE + AB(I,J) = -DCONJG(YB(J))*S(I) + END IF + END IF + END IF + END DO + END DO + + DO I = 1, N + XB(KX + (I-1)*INCX) = YB(I) + END DO + + RETURN + END SUBROUTINE ZTRSV_B + diff --git a/BLAS/src/ztrsv_bv.f b/BLAS/src/ztrsv_bv.f new file mode 100644 index 0000000..8c34b64 --- /dev/null +++ b/BLAS/src/ztrsv_bv.f @@ -0,0 +1,1005 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ztrsv in reverse (adjoint) mode (with options multiDirectional): +C gradient of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:out +C> \brief \b ZTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C COMPLEX*16 A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> ZTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, or A**H*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**H*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX*16 array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is COMPLEX*16 array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE ZTRSV_BV(uplo, trans, diag, n, a, ab, lda, x, xb, incx +C + , nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX*16 a(lda, *), x(*) +C COMPLEX*16 ab(nbdirsmax, lda, *), xb(nbdirsmax, *) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C COMPLEX*16 temp +C COMPLEX*16 tempb(nbdirsmax) +C INTEGER i, info, ix, j, jx, kx +C LOGICAL noconj, nounit +C EXTERNAL LSAME +C INTEGER ISIZE2OFA +CC .. +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC DCONJG, MAX +C INTEGER max1 +C INTEGER nd +C COMPLEX*16 tempb0(nbdirsmax) +C DOUBLE COMPLEX temp0 +C INTEGER ad_from +C INTEGER*4 branch +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_from2 +C INTEGER ad_to +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_to2 +C INTEGER ad_to3 +C INTEGER ad_to4 +C INTEGER ad_to5 +C INTEGER ad_to6 +C INTEGER ii2 +C INTEGER ii1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(4) +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 8 +C ELSE +C CALL PUSHCONTROL3B(5) +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (n .EQ. 0) THEN +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C ELSE +CC +C noconj = LSAME(trans, 'T') +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C CALL PUSHCONTROL1B(0) +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C CALL PUSHCONTROL1B(1) +C kx = 1 +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX16(temp) +C temp = x(j) +C ad_from = j - 1 +C DO i=ad_from,1,-1 +C CALL PUSHCOMPLEX16(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C CALL POPINTEGER4(ad_from) +C DO i=1,ad_from,1 +C CALL POPCOMPLEX16(x(i)) +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) + CONJG(-a(i, j))*xb(nd, i) +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-temp)*xb(nd, +C + i) +C ENDDO +C ENDDO +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(x(j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*xb(nd, j) +C xb(nd, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(x(j)/a(j, j) +C + ))*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX16(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from0 = j - 1 +C DO i=ad_from0,1,-1 +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C CALL PUSHCOMPLEX16(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C CALL POPINTEGER4(ad_from0) +C DO i=1,ad_from0,1 +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) + CONJG(-a(i, j))*xb(nd, ix) +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-temp)*xb(nd, +C + ix) +C ENDDO +C CALL POPCOMPLEX16(x(ix)) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(x(jx)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*xb(nd, jx) +C xb(nd, jx) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(x(jx)/a(j, j +C + )))*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX16(temp) +C temp = x(j) +C ad_from1 = j + 1 +C DO i=ad_from1,n +C CALL PUSHCOMPLEX16(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C CALL POPINTEGER4(ad_from1) +C DO i=n,ad_from1,-1 +C CALL POPCOMPLEX16(x(i)) +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) + CONJG(-a(i, j))*xb(nd, i) +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-temp)*xb(nd, i) +C ENDDO +C ENDDO +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(x(j)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*xb(nd, j) +C xb(nd, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(x(j)/a(j, j))) +C + *tempb0(nd) +C ENDDO +C END IF +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHCOMPLEX16(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from2 = j + 1 +C DO i=ad_from2,n +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C CALL PUSHCOMPLEX16(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C DO nd=1,nbdirsmax +C tempb(nd) = (0.0,0.0) +C ENDDO +C CALL POPINTEGER4(ad_from2) +C DO i=n,ad_from2,-1 +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) + CONJG(-a(i, j))*xb(nd, ix) +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-temp)*xb(nd, ix +C + ) +C ENDDO +C CALL POPCOMPLEX16(x(ix)) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(x(jx)) +C DO nd=1,nbdirs +C tempb0(nd) = CONJG(1.0/a(j, j))*xb(nd, jx) +C xb(nd, jx) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(x(jx)/a(j, j)) +C + )*tempb0(nd) +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x or x := inv( A**H )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C temp = x(j) +C IF (noconj) THEN +C DO i=1,j-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=1,j-1 +C temp = temp - DCONJG(a(i, j))*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPCOMPLEX16(x(j)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, j) +C xb(nd, j) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(temp/a(j, j) +C + ))*tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-x(i))*tempb( +C + nd) +C xb(nd, i) = xb(nd, i) + CONJG(-a(i, j))*tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(j, j)) +C DO nd=1,nbdirs +C ab(nd, j, j) = ab(nd, j, j) + DCONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to0) +C DO i=ad_to0,1,-1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + DCONJG(CONJG(-x(i))* +C + tempb(nd)) +C xb(nd, i) = xb(nd, i) + CONJG(-DCONJG(a(i, j)))* +C + tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C ix = kx +C temp = x(jx) +C IF (noconj) THEN +C DO i=1,j-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=1,j-1 +C temp = temp - DCONJG(a(i, j))*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C CALL POPCOMPLEX16(x(jx)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, jx) +C xb(nd, jx) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(temp/a(j, j) +C + ))*tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO i=ad_to1,1,-1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-x(ix))*tempb( +C + nd) +C xb(nd, ix) = xb(nd, ix) + CONJG(-a(i, j))*tempb(nd +C + ) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(j, j)) +C DO nd=1,nbdirs +C ab(nd, j, j) = ab(nd, j, j) + DCONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to2) +C DO i=ad_to2,1,-1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + DCONJG(CONJG(-x(ix)) +C + *tempb(nd)) +C xb(nd, ix) = xb(nd, ix) + CONJG(-DCONJG(a(i, j)))* +C + tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C temp = x(j) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp = temp - DCONJG(a(i, j))*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPCOMPLEX16(x(j)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, j) +C xb(nd, j) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(temp/a(j, j))) +C + *tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to3) +C DO i=ad_to3,n,1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-x(i))*tempb(nd) +C xb(nd, i) = xb(nd, i) + CONJG(-a(i, j))*tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(j, j)) +C DO nd=1,nbdirs +C ab(nd, j, j) = ab(nd, j, j) + DCONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to4) +C DO i=ad_to4,n,1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + DCONJG(CONJG(-x(i))* +C + tempb(nd)) +C xb(nd, i) = xb(nd, i) + CONJG(-DCONJG(a(i, j)))* +C + tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C ix = kx +C temp = x(jx) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL2B(0) +C ELSE +C CALL PUSHCONTROL2B(1) +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp = temp - DCONJG(a(i, j))*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHCOMPLEX16(temp) +C temp = temp/DCONJG(a(j, j)) +C CALL PUSHCONTROL2B(2) +C ELSE +C CALL PUSHCONTROL2B(3) +C END IF +C END IF +C CALL PUSHCOMPLEX16(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = (0.0,0.0) +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C CALL POPCOMPLEX16(x(jx)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, jx) +C xb(nd, jx) = (0.0,0.0) +C ENDDO +C CALL POPCONTROL2B(branch) +C IF (branch .LT. 2) THEN +C IF (branch .EQ. 0) THEN +C CALL POPCOMPLEX16(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) + CONJG(-(temp/a(j, j))) +C + *tempb0(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to5) +C DO i=ad_to5,n,1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + CONJG(-x(ix))*tempb(nd +C + ) +C xb(nd, ix) = xb(nd, ix) + CONJG(-a(i, j))*tempb(nd) +C ENDDO +C ENDDO +C ELSE +C IF (branch .EQ. 2) THEN +C CALL POPCOMPLEX16(temp) +C temp0 = DCONJG(a(j, j)) +C DO nd=1,nbdirs +C ab(nd, j, j) = ab(nd, j, j) + DCONJG(CONJG(-(temp/ +C + temp0**2))*tempb(nd)) +C tempb(nd) = CONJG(1.0/temp0)*tempb(nd) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to6) +C DO i=ad_to6,n,1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) + DCONJG(CONJG(-x(ix))* +C + tempb(nd)) +C xb(nd, ix) = xb(nd, ix) + CONJG(-DCONJG(a(i, j)))* +C + tempb(nd) +C ENDDO +C ENDDO +C END IF +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C ENDDO +C END IF +C CALL POPCONTROL1B(branch) +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE ZTRSV_BV(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, + + INCX, NBDIRS) + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX, NBDIRS + COMPLEX*16 A(LDA,*), AB(NBDIRSMAX,LDA,*) + COMPLEX*16 X(*), XB(NBDIRSMAX,*) + + COMPLEX*16 BLOC(N), S(N), YB(N), AB_SLICE(LDA,LDA) + LOGICAL UPPER, UNIT, ISN, IST, ISC + INTEGER ND, I, J, KX + INTRINSIC DCONJG + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + ISN = (TRANS.EQ.'N' .OR. TRANS.EQ.'n') + IST = (TRANS.EQ.'T' .OR. TRANS.EQ.'t') + ISC = (TRANS.EQ.'C' .OR. TRANS.EQ.'c') + + DO I = 1, N + BLOC(I) = X(KX + (I-1)*INCX) + END DO + DO I = 1, N + S(I) = BLOC(I) + END DO + CALL ZTRSV(UPLO, TRANS, DIAG, N, A, LDA, S, 1) + + DO ND = 1, NBDIRS + + DO I = 1, N + YB(I) = XB(ND, KX + (I-1)*INCX) + END DO + + IF (ISN) THEN + CALL ZTRSV(UPLO, 'C', DIAG, N, A, LDA, YB, 1) + ELSE IF (ISC) THEN + CALL ZTRSV(UPLO, 'N', DIAG, N, A, LDA, YB, 1) + ELSE + DO I = 1, N + YB(I) = DCONJG(YB(I)) + END DO + CALL ZTRSV(UPLO, 'N', DIAG, N, A, LDA, YB, 1) + DO I = 1, N + YB(I) = DCONJG(YB(I)) + END DO + END IF + + DO J = 1, LDA + DO I = 1, LDA + AB_SLICE(I,J) = (0.0D0, 0.0D0) + END DO + END DO + + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (ISN) THEN + AB_SLICE(I,J) = -YB(I)*DCONJG(S(J)) + ELSE IF (IST) THEN + AB_SLICE(I,J) = -YB(J)*DCONJG(S(I)) + ELSE + AB_SLICE(I,J) = -DCONJG(YB(J))*S(I) + END IF + END IF + END IF + END DO + END DO + + DO I = 1, N + XB(ND, KX + (I-1)*INCX) = YB(I) + END DO + DO J = 1, LDA + DO I = 1, LDA + AB(ND,I,J) = AB_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE ZTRSV_BV + diff --git a/BLAS/src/ztrsv_d.f b/BLAS/src/ztrsv_d.f new file mode 100644 index 0000000..fc4c345 --- /dev/null +++ b/BLAS/src/ztrsv_d.f @@ -0,0 +1,494 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ztrsv in forward (tangent) mode: +C variations of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:in +C> \brief \b ZTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C COMPLEX*16 A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> ZTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, or A**H*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**H*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX*16 array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is COMPLEX*16 array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE ZTRSV_D(uplo, trans, diag, n, a, ad, lda, x, xd, incx) +C IMPLICIT NONE +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX*16 a(lda, *), x(*) +C COMPLEX*16 ad(lda, *), xd(*) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C COMPLEX*16 temp +C COMPLEX*16 tempd +C INTEGER i, info, ix, j, jx, kx +C LOGICAL noconj, nounit +C EXTERNAL LSAME +CC .. +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC DCONJG, MAX +C INTEGER max1 +C COMPLEX*16 temp0 +C DOUBLE COMPLEX temp1 +CC .. +CC +CC Test the input parameters. +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 3 +C ELSE IF (n .LT. 0) THEN +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C info = 8 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('ZTRSV ', info) +C RETURN +C ELSE IF (n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE +CC +C noconj = LSAME(trans, 'T') +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C kx = 1 +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) +C x(j) = temp0 +C END IF +C tempd = xd(j) +C temp = x(j) +C DO i=j-1,1,-1 +C xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) +C x(jx) = temp0 +C END IF +C tempd = xd(jx) +C temp = x(jx) +C ix = jx +C DO i=j-1,1,-1 +C ix = ix - incx +C xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx - incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) +C x(j) = temp0 +C END IF +C tempd = xd(j) +C temp = x(j) +C DO i=j+1,n +C xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) +C x(jx) = temp0 +C END IF +C tempd = xd(jx) +C temp = x(jx) +C ix = jx +C DO i=j+1,n +C ix = ix + incx +C xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x or x := inv( A**H )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C tempd = xd(j) +C temp = x(j) +C IF (noconj) THEN +C DO i=1,j-1 +C tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C ELSE +C DO i=1,j-1 +C temp1 = DCONJG(a(i, j)) +C tempd = tempd - x(i)*DCONJG(ad(i, j)) - temp1*xd(i) +C temp = temp - temp1*x(i) +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(j, j)) +C tempd = (tempd-temp*DCONJG(ad(j, j))/temp1)/temp1 +C temp = temp/temp1 +C END IF +C END IF +C xd(j) = tempd +C x(j) = temp +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C ix = kx +C tempd = xd(jx) +C temp = x(jx) +C IF (noconj) THEN +C DO i=1,j-1 +C tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) +C temp = temp - a(i, j)*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C ELSE +C DO i=1,j-1 +C temp1 = DCONJG(a(i, j)) +C tempd = tempd - x(ix)*DCONJG(ad(i, j)) - temp1*xd(ix) +C temp = temp - temp1*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(j, j)) +C tempd = (tempd-temp*DCONJG(ad(j, j))/temp1)/temp1 +C temp = temp/temp1 +C END IF +C END IF +C xd(jx) = tempd +C x(jx) = temp +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C tempd = xd(j) +C temp = x(j) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp1 = DCONJG(a(i, j)) +C tempd = tempd - x(i)*DCONJG(ad(i, j)) - temp1*xd(i) +C temp = temp - temp1*x(i) +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(j, j)) +C tempd = (tempd-temp*DCONJG(ad(j, j))/temp1)/temp1 +C temp = temp/temp1 +C END IF +C END IF +C xd(j) = tempd +C x(j) = temp +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C ix = kx +C tempd = xd(jx) +C temp = x(jx) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) +C temp = temp - a(i, j)*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp1 = DCONJG(a(i, j)) +C tempd = tempd - x(ix)*DCONJG(ad(i, j)) - temp1*xd(ix) +C temp = temp - temp1*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(j, j)) +C tempd = (tempd-temp*DCONJG(ad(j, j))/temp1)/temp1 +C temp = temp/temp1 +C END IF +C END IF +C xd(jx) = tempd +C x(jx) = temp +C jx = jx - incx +C ENDDO +C END IF +CC +C RETURN +CC +CC End of ZTRSV +CC +C END IF +C END + + SUBROUTINE ZTRSV_D(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, INCX) + IMPLICIT NONE + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX + COMPLEX*16 A(LDA,*), AD(LDA,*) + COMPLEX*16 X(*), XD(*) + + COMPLEX*16 S(N), W(N) + INTEGER I, KX + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + CALL ZTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + DO I = 1, N + S(I) = X(KX + (I-1)*INCX) + END DO + + DO I = 1, N + W(I) = S(I) + END DO + CALL ZTRMV(UPLO, TRANS, DIAG, N, AD, LDA, W, 1) + + DO I = 1, N + W(I) = XD(KX + (I-1)*INCX) - W(I) + END DO + + CALL ZTRSV(UPLO, TRANS, DIAG, N, A, LDA, W, 1) + + DO I = 1, N + XD(KX + (I-1)*INCX) = W(I) + END DO + + RETURN + END SUBROUTINE ZTRSV_D + diff --git a/BLAS/src/ztrsv_dv.f b/BLAS/src/ztrsv_dv.f new file mode 100644 index 0000000..48dee17 --- /dev/null +++ b/BLAS/src/ztrsv_dv.f @@ -0,0 +1,612 @@ +C Generated by TAPENADE (INRIA, Ecuador team) +C Tapenade 3.16 (develop) - 14 Mar 2025 11:54 +C +C Differentiation of ztrsv in forward (tangent) mode (with options multiDirectional): +C variations of useful results: x +C with respect to varying inputs: x a +C RW status of diff variables: x:in-out a:in +C> \brief \b ZTRSV +C +C =========== DOCUMENTATION =========== +C +C Online html documentation available at +C http://www.netlib.org/lapack/explore-html/ +C +C Definition: +C =========== +C +C SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +C +C .. Scalar Arguments .. +C INTEGER INCX,LDA,N +C CHARACTER DIAG,TRANS,UPLO +C .. +C .. Array Arguments .. +C COMPLEX*16 A(LDA,*),X(*) +C .. +C +C +C> \par Purpose: +C ============= +C> +C> \verbatim +C> +C> ZTRSV solves one of the systems of equations +C> +C> A*x = b, or A**T*x = b, or A**H*x = b, +C> +C> where b and x are n element vectors and A is an n by n unit, or +C> non-unit, upper or lower triangular matrix. +C> +C> No test for singularity or near-singularity is included in this +C> routine. Such tests must be performed before calling this routine. +C> \endverbatim +C +C Arguments: +C ========== +C +C> \param[in] UPLO +C> \verbatim +C> UPLO is CHARACTER*1 +C> On entry, UPLO specifies whether the matrix is an upper or +C> lower triangular matrix as follows: +C> +C> UPLO = 'U' or 'u' A is an upper triangular matrix. +C> +C> UPLO = 'L' or 'l' A is a lower triangular matrix. +C> \endverbatim +C> +C> \param[in] TRANS +C> \verbatim +C> TRANS is CHARACTER*1 +C> On entry, TRANS specifies the equations to be solved as +C> follows: +C> +C> TRANS = 'N' or 'n' A*x = b. +C> +C> TRANS = 'T' or 't' A**T*x = b. +C> +C> TRANS = 'C' or 'c' A**H*x = b. +C> \endverbatim +C> +C> \param[in] DIAG +C> \verbatim +C> DIAG is CHARACTER*1 +C> On entry, DIAG specifies whether or not A is unit +C> triangular as follows: +C> +C> DIAG = 'U' or 'u' A is assumed to be unit triangular. +C> +C> DIAG = 'N' or 'n' A is not assumed to be unit +C> triangular. +C> \endverbatim +C> +C> \param[in] N +C> \verbatim +C> N is INTEGER +C> On entry, N specifies the order of the matrix A. +C> N must be at least zero. +C> \endverbatim +C> +C> \param[in] A +C> \verbatim +C> A is COMPLEX*16 array, dimension ( LDA, N ) +C> Before entry with UPLO = 'U' or 'u', the leading n by n +C> upper triangular part of the array A must contain the upper +C> triangular matrix and the strictly lower triangular part of +C> A is not referenced. +C> Before entry with UPLO = 'L' or 'l', the leading n by n +C> lower triangular part of the array A must contain the lower +C> triangular matrix and the strictly upper triangular part of +C> A is not referenced. +C> Note that when DIAG = 'U' or 'u', the diagonal elements of +C> A are not referenced either, but are assumed to be unity. +C> \endverbatim +C> +C> \param[in] LDA +C> \verbatim +C> LDA is INTEGER +C> On entry, LDA specifies the first dimension of A as declared +C> in the calling (sub) program. LDA must be at least +C> max( 1, n ). +C> \endverbatim +C> +C> \param[in,out] X +C> \verbatim +C> X is COMPLEX*16 array, dimension at least +C> ( 1 + ( n - 1 )*abs( INCX ) ). +C> Before entry, the incremented array X must contain the n +C> element right-hand side vector b. On exit, X is overwritten +C> with the solution vector x. +C> \endverbatim +C> +C> \param[in] INCX +C> \verbatim +C> INCX is INTEGER +C> On entry, INCX specifies the increment for the elements of +C> X. INCX must not be zero. +C> \endverbatim +C +C Authors: +C ======== +C +C> \author Univ. of Tennessee +C> \author Univ. of California Berkeley +C> \author Univ. of Colorado Denver +C> \author NAG Ltd. +C +C> \ingroup trsv +C +C> \par Further Details: +C ===================== +C> +C> \verbatim +C> +C> Level 2 Blas routine. +C> +C> -- Written on 22-October-1986. +C> Jack Dongarra, Argonne National Lab. +C> Jeremy Du Croz, Nag Central Office. +C> Sven Hammarling, Nag Central Office. +C> Richard Hanson, Sandia National Labs. +C> \endverbatim +C> +C ===================================================================== +C SUBROUTINE ZTRSV_DV(uplo, trans, diag, n, a, ad, lda, x, xd, incx +C + , nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C COMPLEX*16 a(lda, *), x(*) +C COMPLEX*16 ad(nbdirsmax, lda, *), xd(nbdirsmax, *) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C COMPLEX*16 temp +C COMPLEX*16 tempd(nbdirsmax) +C INTEGER i, info, ix, j, jx, kx +C LOGICAL noconj, nounit +C EXTERNAL LSAME +CC .. +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC DCONJG, MAX +C INTEGER max1 +C INTEGER nd +C COMPLEX*16 temp0 +C DOUBLE COMPLEX temp1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 3 +C ELSE IF (n .LT. 0) THEN +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C info = 8 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('ZTRSV ', info) +C RETURN +C ELSE IF (n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE +CC +C noconj = LSAME(trans, 'T') +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C kx = 1 +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(j) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=j-1,1,-1 +C DO nd=1,nbdirs +C xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad( +C + nd, i, j) +C ENDDO +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(jx) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = jx +C DO i=j-1,1,-1 +C ix = ix - incx +C DO nd=1,nbdirs +C xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp* +C + ad(nd, i, j) +C ENDDO +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx - incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(j) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=j+1,n +C DO nd=1,nbdirs +C xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad(nd +C + , i, j) +C ENDDO +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(jx) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = jx +C DO i=j+1,n +C ix = ix + incx +C DO nd=1,nbdirs +C xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp*ad( +C + nd, i, j) +C ENDDO +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x or x := inv( A**H )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C IF (noconj) THEN +C DO i=1,j-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)* +C + xd(nd, i) +C ENDDO +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO i=1,j-1 +C temp1 = DCONJG(a(i, j)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*DCONJG(ad(nd, i, j)) - +C + temp1*xd(nd, i) +C ENDDO +C temp = temp - temp1*x(i) +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(j, j)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*DCONJG(ad(nd, j, j))/ +C + temp1)/temp1 +C ENDDO +C temp = temp/temp1 +C END IF +C END IF +C DO nd=1,nbdirs +C xd(nd, j) = tempd(nd) +C ENDDO +C x(j) = temp +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C ix = kx +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C IF (noconj) THEN +C DO i=1,j-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j) +C + *xd(nd, ix) +C ENDDO +C temp = temp - a(i, j)*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO i=1,j-1 +C temp1 = DCONJG(a(i, j)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*DCONJG(ad(nd, i, j)) - +C + temp1*xd(nd, ix) +C ENDDO +C temp = temp - temp1*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(j, j)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*DCONJG(ad(nd, j, j))/ +C + temp1)/temp1 +C ENDDO +C temp = temp/temp1 +C END IF +C END IF +C DO nd=1,nbdirs +C xd(nd, jx) = tempd(nd) +C ENDDO +C x(jx) = temp +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd +C + (nd, i) +C ENDDO +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp1 = DCONJG(a(i, j)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*DCONJG(ad(nd, i, j)) - +C + temp1*xd(nd, i) +C ENDDO +C temp = temp - temp1*x(i) +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(j, j)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*DCONJG(ad(nd, j, j))/temp1 +C + )/temp1 +C ENDDO +C temp = temp/temp1 +C END IF +C END IF +C DO nd=1,nbdirs +C xd(nd, j) = tempd(nd) +C ENDDO +C x(j) = temp +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C ix = kx +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C IF (noconj) THEN +C DO i=n,j+1,-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)* +C + xd(nd, ix) +C ENDDO +C temp = temp - a(i, j)*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C ELSE +C DO i=n,j+1,-1 +C temp1 = DCONJG(a(i, j)) +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*DCONJG(ad(nd, i, j)) - +C + temp1*xd(nd, ix) +C ENDDO +C temp = temp - temp1*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp1 = DCONJG(a(j, j)) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp*DCONJG(ad(nd, j, j))/temp1 +C + )/temp1 +C ENDDO +C temp = temp/temp1 +C END IF +C END IF +C DO nd=1,nbdirs +C xd(nd, jx) = tempd(nd) +C ENDDO +C x(jx) = temp +C jx = jx - incx +C ENDDO +C END IF +CC +C RETURN +CC +CC End of ZTRSV +CC +C END IF +C END + + SUBROUTINE ZTRSV_DV(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, + + INCX, NBDIRS) + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX, NBDIRS + COMPLEX*16 A(LDA,*), AD(NBDIRSMAX,LDA,*) + COMPLEX*16 X(*), XD(NBDIRSMAX,*) + + COMPLEX*16 S(N), T(N), W(N), AD_SLICE(LDA,LDA) + INTEGER ND, I, J, KX + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 + END IF + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + + CALL ZTRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + DO I = 1, N + S(I) = X(KX + (I-1)*INCX) + END DO + + DO ND = 1, NBDIRS + + DO J = 1, N + DO I = 1, N + AD_SLICE(I,J) = AD(ND,I,J) + END DO + END DO + + DO I = 1, N + T(I) = S(I) + END DO + CALL ZTRMV(UPLO, TRANS, DIAG, N, AD_SLICE, LDA, T, 1) + + DO I = 1, N + W(I) = XD(ND, KX + (I-1)*INCX) - T(I) + END DO + + CALL ZTRSV(UPLO, TRANS, DIAG, N, A, LDA, W, 1) + + DO I = 1, N + XD(ND, KX + (I-1)*INCX) = W(I) + END DO + + END DO + + RETURN + END SUBROUTINE ZTRSV_DV + diff --git a/BLAS/test/test_ctrsm.f90 b/BLAS/test/test_ctrsm.f90 new file mode 100644 index 0000000..4c0a8e3 --- /dev/null +++ b/BLAS/test/test_ctrsm.f90 @@ -0,0 +1,223 @@ +! Test program for CTRSM differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision + +program test_ctrsm + implicit none + + integer :: seed_array(33) + + external :: ctrsm + external :: ctrsm_d + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + complex(4) :: alpha + complex(4), dimension(max_size,max_size) :: a + integer :: lda_val + complex(4), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Derivative variables + complex(4) :: alpha_d + complex(4), dimension(max_size,max_size) :: a_d + complex(4), dimension(max_size,max_size) :: b_d + + ! Storage variables for inout parameters + complex(4), dimension(max_size,max_size) :: b_output + + ! Array restoration variables for numerical differentiation + complex(4) :: alpha_orig + complex(4), dimension(max_size,max_size) :: a_orig + complex(4), dimension(max_size,max_size) :: b_orig + + ! Variables for central difference computation + complex(4), dimension(max_size,max_size) :: b_forward, b_backward + ! Scalar variables for central difference computation + complex(4) :: central_diff, ad_result + logical :: has_large_errors + + ! Variables for storing original derivative values + complex(4), dimension(max_size,max_size) :: a_d_orig + complex(4) :: alpha_d_orig + complex(4), dimension(max_size,max_size) :: b_d_orig + + ! Temporary variables for matrix initialization + real(4) :: temp_real, temp_imag + integer :: i, j + + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(temp_real) + call random_number(temp_imag) + alpha = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + lda_val = lda ! LDA must be at least max( 1 + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + b(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + ldb_val = ldb + + ! Initialize input derivatives to random values + call random_number(temp_real) + call random_number(temp_imag) + alpha_d = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + a_d(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + b_d(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + + ! Store initial derivative values after random initialization + a_d_orig = a_d + alpha_d_orig = alpha_d + b_d_orig = b_d + + ! Store original values for central difference computation + alpha_orig = alpha + a_orig = a + b_orig = b + + write(*,*) 'Testing CTRSM' + ! Store input values of inout parameters before first function call + b_orig = b + + ! Re-initialize data for differentiated function + ! Only reinitialize inout parameters - keep input-only parameters unchanged + + ! side already has correct value from original call + ! uplo already has correct value from original call + ! transa already has correct value from original call + ! diag already has correct value from original call + msize = n + nsize = n + ! alpha already has correct value from original call + ! a already has correct value from original call + lda_val = lda ! LDA must be at least max( 1 + b = b_orig + ldb_val = ldb + + ! Call the differentiated function + call ctrsm_d(side, uplo, transa, diag, msize, nsize, alpha, alpha_d, a, a_d, lda_val, b, b_d, ldb_val) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(4), parameter :: h = 1.0e-3 ! Step size for finite differences + real(4) :: relative_error, max_error + real(4) :: output_orig, output_pert + real(4) :: numerical_result, analytical_result + real(4) :: abs_error, abs_reference, error_bound + integer :: i, j + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3 + + ! Original values already stored in main program + + ! Central difference computation: f(x + h) - f(x - h) / (2h) + ! Forward perturbation: f(x + h) + alpha = alpha_orig + cmplx(h, 0.0) * alpha_d_orig + a = a_orig + cmplx(h, 0.0) * a_d_orig + b = b_orig + cmplx(h, 0.0) * b_d_orig + call ctrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + ! Store forward perturbation results + b_forward = b + + ! Backward perturbation: f(x - h) + alpha = alpha_orig - cmplx(h, 0.0) * alpha_d_orig + a = a_orig - cmplx(h, 0.0) * a_d_orig + b = b_orig - cmplx(h, 0.0) * b_d_orig + call ctrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + ! Store backward perturbation results + b_backward = b + + ! Compute central differences and compare with AD results + ! Check derivatives for output B + do j = 1, min(2, n) ! Check only first few elements + do i = 1, min(2, n) + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (b_forward(i,j) - b_backward(i,j)) / (2.0e0 * h) + ! AD result + ad_result = b_d(i,j) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-3 + 1.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) 'Large error in output B(', i, ',', j, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_ctrsm diff --git a/BLAS/test/test_ctrsm_reverse.f90 b/BLAS/test/test_ctrsm_reverse.f90 new file mode 100644 index 0000000..90a43bd --- /dev/null +++ b/BLAS/test/test_ctrsm_reverse.f90 @@ -0,0 +1,287 @@ +! Test program for CTRSM reverse mode (adjoint) differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision +! Verification uses VJP methodology with finite differences + +program test_ctrsm_reverse + implicit none + + integer :: seed_array(33) + + external :: ctrsm + external :: ctrsm_b + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + complex(4) :: alpha + complex(4), dimension(max_size,max_size) :: a + integer :: lda_val + complex(4), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Adjoint variables (reverse mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + complex(4) :: alphab + complex(4), dimension(max_size,max_size) :: ab + complex(4), dimension(max_size,max_size) :: bb + + ! Storage for original values (for VJP verification) + complex(4) :: alpha_orig + complex(4), dimension(max_size,max_size) :: a_orig + complex(4), dimension(max_size,max_size) :: b_orig + + ! Variables for VJP verification via finite differences + complex(4), dimension(max_size,max_size) :: b_plus, b_minus + + ! Saved cotangents (output adjoints) for VJP verification + complex(4), dimension(max_size,max_size) :: bb_orig + real(4), parameter :: h = 1.0e-3 + real(4) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + integer :: i, j + real(4), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Temporary variables for complex random initialization + real(4) :: temp_real_init, temp_imag_init + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + ! Initialize primal values + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(temp_real_init) + call random_number(temp_imag_init) + alpha = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + a(i,j) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + end do + lda_val = lda + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + b(i,j) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + end do + ldb_val = ldb + + ! Store original primal values + alpha_orig = alpha + a_orig = a + b_orig = b + + write(*,*) 'Testing CTRSM' + + ! Initialize output adjoints (cotangents) with random values + ! These are the 'seeds' for reverse mode + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + bb(i,j) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + end do + + ! Save output adjoints (cotangents) for VJP verification + ! Note: output adjoints may be modified by reverse mode function + bb_orig = bb + + ! Initialize input adjoints to zero (they will be computed) + alphab = 0.0 + ab = 0.0 + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! Differentiated code checks they are set via check_ISIZE*_initialized. + call set_ISIZE2OFA(max_size) + + ! Call reverse mode differentiated function + call ctrsm_b(side, uplo, transa, diag, msize, nsize, alpha, alphab, a, ab, lda_val, b, bb, ldb_val) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + ! For reverse mode, we verify: cotangent^T @ J @ direction = direction^T @ adjoint + ! Equivalently: cotangent^T @ (f(x+h*dir) - f(x-h*dir))/(2h) should equal dir^T @ computed_adjoint + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Temporary variables for complex random number generation + real(4) :: temp_real, temp_imag + + ! Direction vectors for VJP testing (like tangents in forward mode) + complex(4) :: alpha_dir + complex(4), dimension(max_size,max_size) :: a_dir + complex(4), dimension(max_size,max_size) :: b_dir + + complex(4), dimension(max_size,max_size) :: b_central_diff + + max_error = 0.0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Initialize random direction vectors for all inputs + call random_number(temp_real) + call random_number(temp_imag) + alpha_dir = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a_dir(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + b_dir(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + + ! Forward perturbation: f(x + h*dir) + alpha = alpha_orig + cmplx(h, 0.0) * alpha_dir + a = a_orig + cmplx(h, 0.0) * a_dir + b = b_orig + cmplx(h, 0.0) * b_dir + call ctrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_plus = b + + ! Backward perturbation: f(x - h*dir) + alpha = alpha_orig - cmplx(h, 0.0) * alpha_dir + a = a_orig - cmplx(h, 0.0) * a_dir + b = b_orig - cmplx(h, 0.0) * b_dir + call ctrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_minus = b + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + b_central_diff = (b_plus - b_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0 + ! Compute and sort products for b (FD) + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(bb_orig(i,j)) * b_central_diff(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0 + vjp_ad = vjp_ad + real(conjg(alpha_dir) * alphab) + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(a_dir(i,j)) * ab(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for b + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(b_dir(i,j)) * bb(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-3 + 1.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + max_error = relative_error + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(4), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(4) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_ctrsm_reverse diff --git a/BLAS/test/test_ctrsm_vector_forward.f90 b/BLAS/test/test_ctrsm_vector_forward.f90 new file mode 100644 index 0000000..afe2a55 --- /dev/null +++ b/BLAS/test/test_ctrsm_vector_forward.f90 @@ -0,0 +1,202 @@ +! Test program for CTRSM vector forward mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision with nbdirsmax=4 + +program test_ctrsm_vector_forward + implicit none + include 'DIFFSIZES.inc' + + external :: ctrsm + external :: ctrsm_dv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, idir ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + complex(4) :: alpha + complex(4), dimension(max_size,max_size) :: a + integer :: lda_val + complex(4), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Vector mode derivative variables (type-promoted) + ! Scalars become arrays(nbdirsmax), arrays gain extra dimension + complex(4), dimension(nbdirsmax) :: alpha_dv + complex(4), dimension(nbdirsmax,max_size,max_size) :: a_dv + complex(4), dimension(nbdirsmax,max_size,max_size) :: b_dv + ! Declare variables for storing original values + complex(4) :: alpha_orig + complex(4), dimension(nbdirsmax) :: alpha_dv_orig + complex(4), dimension(max_size,max_size) :: a_orig + complex(4), dimension(nbdirsmax,max_size,max_size) :: a_dv_orig + complex(4), dimension(max_size,max_size) :: b_orig + complex(4), dimension(nbdirsmax,max_size,max_size) :: b_dv_orig + + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize test parameters + msize = n + nsize = n + lda_val = lda + ldb_val = ldb + + ! Initialize test data with random numbers + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + call random_number(temp_real) + call random_number(temp_imag) + alpha = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + b(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + + ! Initialize input derivatives to random values (exactly like scalar mode) + do idir = 1, nbdirsmax + call random_number(temp_real) + call random_number(temp_imag) + alpha_dv(idir) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + do idir = 1, nbdirsmax + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a_dv(idir,i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + end do + do idir = 1, nbdirsmax + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + b_dv(idir,i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + end do + + write(*,*) 'Testing CTRSM (Vector Forward Mode)' + ! Store original values before any function calls (critical for INOUT parameters) + alpha_orig = alpha + alpha_dv_orig = alpha_dv + a_orig = a + a_dv_orig = a_dv + b_orig = b + b_dv_orig = b_dv + + ! Call the vector mode differentiated function + + call ctrsm_dv(side, uplo, transa, diag, msize, nsize, alpha, alpha_dv, a, a_dv, lda_val, b, b_dv, ldb_val, nbdirsmax) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Vector forward mode test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(4), parameter :: h = 1.0e-3 ! Step size for finite differences + real(4) :: relative_error, max_error + real(4) :: abs_error, abs_reference, error_bound + complex(4) :: central_diff, ad_result + integer :: i, j, idir + logical :: has_large_errors + complex(4), dimension(max_size,max_size) :: b_forward, b_backward + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + write(*,*) 'Number of directions:', nbdirsmax + + ! Test each derivative direction separately + do idir = 1, nbdirsmax + + ! Forward perturbation: f(x + h * direction) + alpha = alpha_orig + cmplx(h, 0.0) * alpha_dv_orig(idir) + a = a_orig + cmplx(h, 0.0) * a_dv_orig(idir,:,:) + b = b_orig + cmplx(h, 0.0) * b_dv_orig(idir,:,:) + call ctrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_forward = b + + ! Backward perturbation: f(x - h * direction) + alpha = alpha_orig - cmplx(h, 0.0) * alpha_dv_orig(idir) + a = a_orig - cmplx(h, 0.0) * a_dv_orig(idir,:,:) + b = b_orig - cmplx(h, 0.0) * b_dv_orig(idir,:,:) + call ctrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_backward = b + + ! Compute central differences and compare with AD results + do j = 1, min(2, nsize) ! Check only first few elements + do i = 1, min(2, nsize) + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (b_forward(i,j) - b_backward(i,j)) / (2.0e0 * h) + ! AD result + ad_result = b_dv(idir,i,j) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-3 + 1.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) ' Large error in direction', idir, ' output B(', i, ',', j, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_ctrsm_vector_forward \ No newline at end of file diff --git a/BLAS/test/test_ctrsm_vector_reverse.f90 b/BLAS/test/test_ctrsm_vector_reverse.f90 new file mode 100644 index 0000000..3ce615a --- /dev/null +++ b/BLAS/test/test_ctrsm_vector_reverse.f90 @@ -0,0 +1,285 @@ +! Test program for CTRSM vector reverse mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision with nbdirsmax=4 + +program test_ctrsm_vector_reverse + implicit none + include 'DIFFSIZES.inc' + + external :: ctrsm + external :: ctrsm_bv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, k ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + complex(4) :: alpha + complex(4), dimension(max_size,max_size) :: a + integer :: lda_val + complex(4), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Adjoint variables (reverse vector mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + complex(4), dimension(nbdirsmax) :: alphab + complex(4), dimension(nbdirsmax,max_size,max_size) :: ab + complex(4), dimension(nbdirsmax,max_size,max_size) :: bb + + ! Storage for original cotangents (for INOUT parameters in VJP verification) + complex(4), dimension(nbdirsmax,max_size,max_size) :: bb_orig + + ! Storage for original values (for VJP verification) + complex(4) :: alpha_orig + complex(4), dimension(max_size,max_size) :: a_orig + complex(4), dimension(max_size,max_size) :: b_orig + + ! Variables for VJP verification via finite differences + real(4), parameter :: h = 1.0e-3 + real(4) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + real(4), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize primal values + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(temp_real) + call random_number(temp_imag) + alpha = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + lda_val = lda + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + b(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + ldb_val = ldb + + ! Store original primal values + alpha_orig = alpha + a_orig = a + b_orig = b + + ! Initialize output adjoints (cotangents) with random values for each direction + ! These are the 'seeds' for reverse mode + do k = 1, nbdirsmax + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + bb(k,i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + end do + + ! Initialize input adjoints to zero (they will be computed) + ! Note: Inout parameters are skipped - they already have output adjoints initialized + alphab = 0.0 + ab = 0.0 + + ! Save original cotangent seeds for OUTPUT/INOUT parameters (before function call) + bb_orig = bb + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! ISIZE1OF* (vectors): use n to match adjoint array size; ISIZE2OF* (matrices): use max_size. + call set_ISIZE2OFA(max_size) + + ! Call reverse vector mode differentiated function + call ctrsm_bv(side, uplo, transa, diag, msize, nsize, alpha, alphab, a, ab, lda_val, b, bb, ldb_val, nbdirsmax) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing + complex(4) :: alpha_dir + complex(4), dimension(max_size,max_size) :: a_dir + complex(4), dimension(max_size,max_size) :: b_dir + complex(4), dimension(max_size,max_size) :: b_plus, b_minus, b_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Test each differentiation direction separately + do k = 1, nbdirsmax + + ! Initialize random direction vectors for all inputs + call random_number(temp_real) + call random_number(temp_imag) + alpha_dir = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + a_dir(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + b_dir(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + + ! Forward perturbation: f(x + h*dir) + alpha = alpha_orig + cmplx(h, 0.0) * alpha_dir + a = a_orig + cmplx(h, 0.0) * a_dir + b = b_orig + cmplx(h, 0.0) * b_dir + call ctrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_plus = b + + ! Backward perturbation: f(x - h*dir) + alpha = alpha_orig - cmplx(h, 0.0) * alpha_dir + a = a_orig - cmplx(h, 0.0) * a_dir + b = b_orig - cmplx(h, 0.0) * b_dir + call ctrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_minus = b + + ! Compute central differences and VJP verification + ! VJP check: direction^T @ adjoint should equal finite difference + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + b_central_diff = (b_plus - b_minus) / (2.0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0 + ! Compute and sort products for b (FD) + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(bb_orig(k,i,j)) * b_central_diff(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0 + vjp_ad = vjp_ad + real(conjg(alpha_dir) * alphab(k)) + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(a_dir(i,j)) * ab(k,i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for b + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(b_dir(i,j)) * bb(k,i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-3 + 1.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + ! Compute relative error for reporting + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + if (relative_error > max_error) max_error = relative_error + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(4), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(4) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_ctrsm_vector_reverse \ No newline at end of file diff --git a/BLAS/test/test_ctrsv.f90 b/BLAS/test/test_ctrsv.f90 new file mode 100644 index 0000000..4cd9110 --- /dev/null +++ b/BLAS/test/test_ctrsv.f90 @@ -0,0 +1,196 @@ +! Test program for CTRSV differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision + +program test_ctrsv + implicit none + + integer :: seed_array(33) + + external :: ctrsv + external :: ctrsv_d + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: uplo + character :: trans + character :: diag + integer :: nsize + complex(4), dimension(max_size,max_size) :: a + integer :: lda_val + complex(4), dimension(max_size) :: x + integer :: incx_val + + ! Derivative variables + complex(4), dimension(max_size,max_size) :: a_d + complex(4), dimension(max_size) :: x_d + + ! Storage variables for inout parameters + complex(4), dimension(max_size) :: x_output + + ! Array restoration variables for numerical differentiation + complex(4), dimension(max_size,max_size) :: a_orig + complex(4), dimension(max_size) :: x_orig + + ! Variables for central difference computation + complex(4), dimension(max_size) :: x_forward, x_backward + ! Scalar variables for central difference computation + complex(4) :: central_diff, ad_result + logical :: has_large_errors + + ! Variables for storing original derivative values + complex(4), dimension(max_size,max_size) :: a_d_orig + complex(4), dimension(max_size) :: x_d_orig + + ! Temporary variables for matrix initialization + real(4) :: temp_real, temp_imag + integer :: i, j + + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + lda_val = lda ! LDA must be at least max( 1 + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + x(i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + incx_val = 1 ! INCX 1 + + ! Initialize input derivatives to random values + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + a_d(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + x_d(i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + + ! Store initial derivative values after random initialization + a_d_orig = a_d + x_d_orig = x_d + + ! Store original values for central difference computation + a_orig = a + x_orig = x + + write(*,*) 'Testing CTRSV' + ! Store input values of inout parameters before first function call + x_orig = x + + ! Re-initialize data for differentiated function + ! Only reinitialize inout parameters - keep input-only parameters unchanged + + ! uplo already has correct value from original call + ! trans already has correct value from original call + ! diag already has correct value from original call + nsize = n + ! a already has correct value from original call + lda_val = lda ! LDA must be at least max( 1 + x = x_orig + incx_val = 1 ! INCX 1 + + ! Call the differentiated function + call ctrsv_d(uplo, trans, diag, nsize, a, a_d, lda_val, x, x_d, incx_val) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(4), parameter :: h = 1.0e-3 ! Step size for finite differences + real(4) :: relative_error, max_error + real(4) :: output_orig, output_pert + real(4) :: numerical_result, analytical_result + real(4) :: abs_error, abs_reference, error_bound + integer :: i, j + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3 + + ! Original values already stored in main program + + ! Central difference computation: f(x + h) - f(x - h) / (2h) + ! Forward perturbation: f(x + h) + a = a_orig + cmplx(h, 0.0) * a_d_orig + x = x_orig + cmplx(h, 0.0) * x_d_orig + call ctrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + ! Store forward perturbation results + x_forward = x + + ! Backward perturbation: f(x - h) + a = a_orig - cmplx(h, 0.0) * a_d_orig + x = x_orig - cmplx(h, 0.0) * x_d_orig + call ctrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + ! Store backward perturbation results + x_backward = x + + ! Compute central differences and compare with AD results + ! Check derivatives for output X + do i = 1, min(2, n) ! Check only first few elements + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (x_forward(i) - x_backward(i)) / (2.0e0 * h) + ! AD result + ad_result = x_d(i) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-3 + 1.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) 'Large error in output X(', i, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_ctrsv diff --git a/BLAS/test/test_ctrsv_reverse.f90 b/BLAS/test/test_ctrsv_reverse.f90 new file mode 100644 index 0000000..d1fcace --- /dev/null +++ b/BLAS/test/test_ctrsv_reverse.f90 @@ -0,0 +1,256 @@ +! Test program for CTRSV reverse mode (adjoint) differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision +! Verification uses VJP methodology with finite differences + +program test_ctrsv_reverse + implicit none + + integer :: seed_array(33) + + external :: ctrsv + external :: ctrsv_b + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: uplo + character :: trans + character :: diag + integer :: nsize + complex(4), dimension(max_size,max_size) :: a + integer :: lda_val + complex(4), dimension(max_size) :: x + integer :: incx_val + + ! Adjoint variables (reverse mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + complex(4), dimension(max_size,max_size) :: ab + complex(4), dimension(max_size) :: xb + + ! Storage for original values (for VJP verification) + complex(4), dimension(max_size,max_size) :: a_orig + complex(4), dimension(max_size) :: x_orig + + ! Variables for VJP verification via finite differences + complex(4), dimension(max_size) :: x_plus, x_minus + + ! Saved cotangents (output adjoints) for VJP verification + complex(4), dimension(max_size) :: xb_orig + real(4), parameter :: h = 1.0e-3 + real(4) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + integer :: i, j + real(4), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Temporary variables for complex random initialization + real(4) :: temp_real_init, temp_imag_init + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + ! Initialize primal values + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + a(i,j) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + end do + lda_val = lda + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + x(i) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + incx_val = 1 + + ! Store original primal values + a_orig = a + x_orig = x + + write(*,*) 'Testing CTRSV' + + ! Initialize output adjoints (cotangents) with random values + ! These are the 'seeds' for reverse mode + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + xb(i) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + + ! Save output adjoints (cotangents) for VJP verification + ! Note: output adjoints may be modified by reverse mode function + xb_orig = xb + + ! Initialize input adjoints to zero (they will be computed) + ab = 0.0 + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! Differentiated code checks they are set via check_ISIZE*_initialized. + call set_ISIZE2OFA(max_size) + + ! Call reverse mode differentiated function + call ctrsv_b(uplo, trans, diag, nsize, a, ab, lda_val, x, xb, incx_val) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + ! For reverse mode, we verify: cotangent^T @ J @ direction = direction^T @ adjoint + ! Equivalently: cotangent^T @ (f(x+h*dir) - f(x-h*dir))/(2h) should equal dir^T @ computed_adjoint + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Temporary variables for complex random number generation + real(4) :: temp_real, temp_imag + + ! Direction vectors for VJP testing (like tangents in forward mode) + complex(4), dimension(max_size,max_size) :: a_dir + complex(4), dimension(max_size) :: x_dir + + complex(4), dimension(max_size) :: x_central_diff + + max_error = 0.0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Initialize random direction vectors for all inputs + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a_dir(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + x_dir(i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + + ! Forward perturbation: f(x + h*dir) + a = a_orig + cmplx(h, 0.0) * a_dir + x = x_orig + cmplx(h, 0.0) * x_dir + call ctrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_plus = x + + ! Backward perturbation: f(x - h*dir) + a = a_orig - cmplx(h, 0.0) * a_dir + x = x_orig - cmplx(h, 0.0) * x_dir + call ctrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_minus = x + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + x_central_diff = (x_plus - x_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0 + ! Compute and sort products for x (FD) + n_products = n + do i = 1, n + temp_products(i) = real(conjg(xb_orig(i)) * x_central_diff(i)) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0 + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(a_dir(i,j)) * ab(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for x + n_products = n + do i = 1, n + temp_products(i) = real(conjg(x_dir(i)) * xb(i)) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-3 + 1.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + max_error = relative_error + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(4), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(4) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_ctrsv_reverse diff --git a/BLAS/test/test_ctrsv_vector_forward.f90 b/BLAS/test/test_ctrsv_vector_forward.f90 new file mode 100644 index 0000000..5f08568 --- /dev/null +++ b/BLAS/test/test_ctrsv_vector_forward.f90 @@ -0,0 +1,176 @@ +! Test program for CTRSV vector forward mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision with nbdirsmax=4 + +program test_ctrsv_vector_forward + implicit none + include 'DIFFSIZES.inc' + + external :: ctrsv + external :: ctrsv_dv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, idir ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: uplo + character :: trans + character :: diag + integer :: nsize + complex(4), dimension(max_size,max_size) :: a + integer :: lda_val + complex(4), dimension(max_size) :: x + integer :: incx_val + + ! Vector mode derivative variables (type-promoted) + ! Scalars become arrays(nbdirsmax), arrays gain extra dimension + complex(4), dimension(nbdirsmax,max_size,max_size) :: a_dv + complex(4), dimension(nbdirsmax,max_size) :: x_dv + ! Declare variables for storing original values + complex(4), dimension(max_size,max_size) :: a_orig + complex(4), dimension(nbdirsmax,max_size,max_size) :: a_dv_orig + complex(4), dimension(max_size) :: x_orig + complex(4), dimension(nbdirsmax,max_size) :: x_dv_orig + + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize test parameters + nsize = n + lda_val = lda + incx_val = 1 + + ! Initialize test data with random numbers + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + uplo = 'U' + trans = 'N' + diag = 'N' + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + x(i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + + ! Initialize input derivatives to random values (exactly like scalar mode) + do idir = 1, nbdirsmax + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a_dv(idir,i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + end do + do idir = 1, nbdirsmax + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + x_dv(idir,i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + + write(*,*) 'Testing CTRSV (Vector Forward Mode)' + ! Store original values before any function calls (critical for INOUT parameters) + a_orig = a + a_dv_orig = a_dv + x_orig = x + x_dv_orig = x_dv + + ! Call the vector mode differentiated function + + call ctrsv_dv(uplo, trans, diag, nsize, a, a_dv, lda_val, x, x_dv, incx_val, nbdirsmax) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Vector forward mode test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(4), parameter :: h = 1.0e-3 ! Step size for finite differences + real(4) :: relative_error, max_error + real(4) :: abs_error, abs_reference, error_bound + complex(4) :: central_diff, ad_result + integer :: i, j, idir + logical :: has_large_errors + complex(4), dimension(max_size) :: x_forward, x_backward + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + write(*,*) 'Number of directions:', nbdirsmax + + ! Test each derivative direction separately + do idir = 1, nbdirsmax + + ! Forward perturbation: f(x + h * direction) + a = a_orig + cmplx(h, 0.0) * a_dv_orig(idir,:,:) + x = x_orig + cmplx(h, 0.0) * x_dv_orig(idir,:) + call ctrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_forward = x + + ! Backward perturbation: f(x - h * direction) + a = a_orig - cmplx(h, 0.0) * a_dv_orig(idir,:,:) + x = x_orig - cmplx(h, 0.0) * x_dv_orig(idir,:) + call ctrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_backward = x + + ! Compute central differences and compare with AD results + do i = 1, min(2, nsize) ! Check only first few elements + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (x_forward(i) - x_backward(i)) / (2.0e0 * h) + ! AD result + ad_result = x_dv(idir,i) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-3 + 1.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) ' Large error in direction', idir, ' output X(', i, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_ctrsv_vector_forward \ No newline at end of file diff --git a/BLAS/test/test_ctrsv_vector_reverse.f90 b/BLAS/test/test_ctrsv_vector_reverse.f90 new file mode 100644 index 0000000..e6a1e4d --- /dev/null +++ b/BLAS/test/test_ctrsv_vector_reverse.f90 @@ -0,0 +1,254 @@ +! Test program for CTRSV vector reverse mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*4 precision with nbdirsmax=4 + +program test_ctrsv_vector_reverse + implicit none + include 'DIFFSIZES.inc' + + external :: ctrsv + external :: ctrsv_bv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, k ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: uplo + character :: trans + character :: diag + integer :: nsize + complex(4), dimension(max_size,max_size) :: a + integer :: lda_val + complex(4), dimension(max_size) :: x + integer :: incx_val + + ! Adjoint variables (reverse vector mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + complex(4), dimension(nbdirsmax,max_size,max_size) :: ab + complex(4), dimension(nbdirsmax,max_size) :: xb + + ! Storage for original cotangents (for INOUT parameters in VJP verification) + complex(4), dimension(nbdirsmax,max_size) :: xb_orig + + ! Storage for original values (for VJP verification) + complex(4), dimension(max_size,max_size) :: a_orig + complex(4), dimension(max_size) :: x_orig + + ! Variables for VJP verification via finite differences + real(4), parameter :: h = 1.0e-3 + real(4) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + real(4), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize primal values + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + lda_val = lda + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + x(i) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + incx_val = 1 + + ! Store original primal values + a_orig = a + x_orig = x + + ! Initialize output adjoints (cotangents) with random values for each direction + ! These are the 'seeds' for reverse mode + do k = 1, nbdirsmax + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + xb(k,i) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + + ! Initialize input adjoints to zero (they will be computed) + ! Note: Inout parameters are skipped - they already have output adjoints initialized + ab = 0.0 + + ! Save original cotangent seeds for OUTPUT/INOUT parameters (before function call) + xb_orig = xb + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! ISIZE1OF* (vectors): use n to match adjoint array size; ISIZE2OF* (matrices): use max_size. + call set_ISIZE2OFA(max_size) + + ! Call reverse vector mode differentiated function + call ctrsv_bv(uplo, trans, diag, nsize, a, ab, lda_val, x, xb, incx_val, nbdirsmax) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing + complex(4), dimension(max_size,max_size) :: a_dir + complex(4), dimension(max_size) :: x_dir + complex(4), dimension(max_size) :: x_plus, x_minus, x_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Test each differentiation direction separately + do k = 1, nbdirsmax + + ! Initialize random direction vectors for all inputs + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + a_dir(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + x_dir(i) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + + ! Forward perturbation: f(x + h*dir) + a = a_orig + cmplx(h, 0.0) * a_dir + x = x_orig + cmplx(h, 0.0) * x_dir + call ctrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_plus = x + + ! Backward perturbation: f(x - h*dir) + a = a_orig - cmplx(h, 0.0) * a_dir + x = x_orig - cmplx(h, 0.0) * x_dir + call ctrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_minus = x + + ! Compute central differences and VJP verification + ! VJP check: direction^T @ adjoint should equal finite difference + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + x_central_diff = (x_plus - x_minus) / (2.0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0 + ! Compute and sort products for x (FD) + n_products = n + do i = 1, n + temp_products(i) = real(conjg(xb_orig(k,i)) * x_central_diff(i)) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0 + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(a_dir(i,j)) * ab(k,i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for x + n_products = n + do i = 1, n + temp_products(i) = real(conjg(x_dir(i)) * xb(k,i)) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-3 + 1.0e-3 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + ! Compute relative error for reporting + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + if (relative_error > max_error) max_error = relative_error + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-3, atol=1.0e-3' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(4), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(4) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_ctrsv_vector_reverse \ No newline at end of file diff --git a/BLAS/test/test_ztrsm.f90 b/BLAS/test/test_ztrsm.f90 new file mode 100644 index 0000000..75df5e1 --- /dev/null +++ b/BLAS/test/test_ztrsm.f90 @@ -0,0 +1,223 @@ +! Test program for ZTRSM differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision + +program test_ztrsm + implicit none + + integer :: seed_array(33) + + external :: ztrsm + external :: ztrsm_d + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + complex(8) :: alpha + complex(8), dimension(max_size,max_size) :: a + integer :: lda_val + complex(8), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Derivative variables + complex(8) :: alpha_d + complex(8), dimension(max_size,max_size) :: a_d + complex(8), dimension(max_size,max_size) :: b_d + + ! Storage variables for inout parameters + complex(8), dimension(max_size,max_size) :: b_output + + ! Array restoration variables for numerical differentiation + complex(8) :: alpha_orig + complex(8), dimension(max_size,max_size) :: b_orig + complex(8), dimension(max_size,max_size) :: a_orig + + ! Variables for central difference computation + complex(8), dimension(max_size,max_size) :: b_forward, b_backward + ! Scalar variables for central difference computation + complex(8) :: central_diff, ad_result + logical :: has_large_errors + + ! Variables for storing original derivative values + complex(8), dimension(max_size,max_size) :: b_d_orig + complex(8), dimension(max_size,max_size) :: a_d_orig + complex(8) :: alpha_d_orig + + ! Temporary variables for matrix initialization + real(4) :: temp_real, temp_imag + integer :: i, j + + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(temp_real) + call random_number(temp_imag) + alpha = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + lda_val = lda ! LDA must be at least max( 1 + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + b(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + ldb_val = ldb + + ! Initialize input derivatives to random values + call random_number(temp_real) + call random_number(temp_imag) + alpha_d = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + b_d(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + a_d(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + + ! Store initial derivative values after random initialization + b_d_orig = b_d + a_d_orig = a_d + alpha_d_orig = alpha_d + + ! Store original values for central difference computation + alpha_orig = alpha + b_orig = b + a_orig = a + + write(*,*) 'Testing ZTRSM' + ! Store input values of inout parameters before first function call + b_orig = b + + ! Re-initialize data for differentiated function + ! Only reinitialize inout parameters - keep input-only parameters unchanged + + ! side already has correct value from original call + ! uplo already has correct value from original call + ! transa already has correct value from original call + ! diag already has correct value from original call + msize = n + nsize = n + ! alpha already has correct value from original call + ! a already has correct value from original call + lda_val = lda ! LDA must be at least max( 1 + b = b_orig + ldb_val = ldb + + ! Call the differentiated function + call ztrsm_d(side, uplo, transa, diag, msize, nsize, alpha, alpha_d, a, a_d, lda_val, b, b_d, ldb_val) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(8), parameter :: h = 1.0e-6 ! Step size for finite differences + real(8) :: relative_error, max_error + real(8) :: output_orig, output_pert + real(8) :: numerical_result, analytical_result + real(8) :: abs_error, abs_reference, error_bound + integer :: i, j + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5 + + ! Original values already stored in main program + + ! Central difference computation: f(x + h) - f(x - h) / (2h) + ! Forward perturbation: f(x + h) + alpha = alpha_orig + cmplx(h, 0.0) * alpha_d_orig + b = b_orig + cmplx(h, 0.0) * b_d_orig + a = a_orig + cmplx(h, 0.0) * a_d_orig + call ztrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + ! Store forward perturbation results + b_forward = b + + ! Backward perturbation: f(x - h) + alpha = alpha_orig - cmplx(h, 0.0) * alpha_d_orig + b = b_orig - cmplx(h, 0.0) * b_d_orig + a = a_orig - cmplx(h, 0.0) * a_d_orig + call ztrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + ! Store backward perturbation results + b_backward = b + + ! Compute central differences and compare with AD results + ! Check derivatives for output B + do j = 1, min(2, n) ! Check only first few elements + do i = 1, min(2, n) + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (b_forward(i,j) - b_backward(i,j)) / (2.0e0 * h) + ! AD result + ad_result = b_d(i,j) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) 'Large error in output B(', i, ',', j, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_ztrsm diff --git a/BLAS/test/test_ztrsm_reverse.f90 b/BLAS/test/test_ztrsm_reverse.f90 new file mode 100644 index 0000000..5210307 --- /dev/null +++ b/BLAS/test/test_ztrsm_reverse.f90 @@ -0,0 +1,287 @@ +! Test program for ZTRSM reverse mode (adjoint) differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision +! Verification uses VJP methodology with finite differences + +program test_ztrsm_reverse + implicit none + + integer :: seed_array(33) + + external :: ztrsm + external :: ztrsm_b + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + complex(8) :: alpha + complex(8), dimension(max_size,max_size) :: a + integer :: lda_val + complex(8), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Adjoint variables (reverse mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + complex(8) :: alphab + complex(8), dimension(max_size,max_size) :: ab + complex(8), dimension(max_size,max_size) :: bb + + ! Storage for original values (for VJP verification) + complex(8) :: alpha_orig + complex(8), dimension(max_size,max_size) :: a_orig + complex(8), dimension(max_size,max_size) :: b_orig + + ! Variables for VJP verification via finite differences + complex(8), dimension(max_size,max_size) :: b_plus, b_minus + + ! Saved cotangents (output adjoints) for VJP verification + complex(8), dimension(max_size,max_size) :: bb_orig + real(8), parameter :: h = 1.0e-7 + real(8) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + integer :: i, j + real(8), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Temporary variables for complex random initialization + real(4) :: temp_real_init, temp_imag_init + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + ! Initialize primal values + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(temp_real_init) + call random_number(temp_imag_init) + alpha = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + a(i,j) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + end do + lda_val = lda + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + b(i,j) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + end do + ldb_val = ldb + + ! Store original primal values + alpha_orig = alpha + a_orig = a + b_orig = b + + write(*,*) 'Testing ZTRSM' + + ! Initialize output adjoints (cotangents) with random values + ! These are the 'seeds' for reverse mode + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + bb(i,j) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + end do + + ! Save output adjoints (cotangents) for VJP verification + ! Note: output adjoints may be modified by reverse mode function + bb_orig = bb + + ! Initialize input adjoints to zero (they will be computed) + alphab = 0.0d0 + ab = 0.0d0 + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! Differentiated code checks they are set via check_ISIZE*_initialized. + call set_ISIZE2OFA(max_size) + + ! Call reverse mode differentiated function + call ztrsm_b(side, uplo, transa, diag, msize, nsize, alpha, alphab, a, ab, lda_val, b, bb, ldb_val) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + ! For reverse mode, we verify: cotangent^T @ J @ direction = direction^T @ adjoint + ! Equivalently: cotangent^T @ (f(x+h*dir) - f(x-h*dir))/(2h) should equal dir^T @ computed_adjoint + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Temporary variables for complex random number generation + real(4) :: temp_real, temp_imag + + ! Direction vectors for VJP testing (like tangents in forward mode) + complex(8) :: alpha_dir + complex(8), dimension(max_size,max_size) :: a_dir + complex(8), dimension(max_size,max_size) :: b_dir + + complex(8), dimension(max_size,max_size) :: b_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Initialize random direction vectors for all inputs + call random_number(temp_real) + call random_number(temp_imag) + alpha_dir = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a_dir(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + b_dir(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + + ! Forward perturbation: f(x + h*dir) + alpha = alpha_orig + cmplx(h, 0.0) * alpha_dir + a = a_orig + cmplx(h, 0.0) * a_dir + b = b_orig + cmplx(h, 0.0) * b_dir + call ztrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_plus = b + + ! Backward perturbation: f(x - h*dir) + alpha = alpha_orig - cmplx(h, 0.0) * alpha_dir + a = a_orig - cmplx(h, 0.0) * a_dir + b = b_orig - cmplx(h, 0.0) * b_dir + call ztrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_minus = b + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + b_central_diff = (b_plus - b_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0d0 + ! Compute and sort products for b (FD) + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(bb_orig(i,j)) * b_central_diff(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0d0 + vjp_ad = vjp_ad + real(conjg(alpha_dir) * alphab) + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(a_dir(i,j)) * ab(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for b + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(b_dir(i,j)) * bb(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + max_error = relative_error + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(8), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(8) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_ztrsm_reverse diff --git a/BLAS/test/test_ztrsm_vector_forward.f90 b/BLAS/test/test_ztrsm_vector_forward.f90 new file mode 100644 index 0000000..269d8bb --- /dev/null +++ b/BLAS/test/test_ztrsm_vector_forward.f90 @@ -0,0 +1,202 @@ +! Test program for ZTRSM vector forward mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision with nbdirsmax=4 + +program test_ztrsm_vector_forward + implicit none + include 'DIFFSIZES.inc' + + external :: ztrsm + external :: ztrsm_dv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, idir ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + complex(8) :: alpha + complex(8), dimension(max_size,max_size) :: a + integer :: lda_val + complex(8), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Vector mode derivative variables (type-promoted) + ! Scalars become arrays(nbdirsmax), arrays gain extra dimension + complex(8), dimension(nbdirsmax) :: alpha_dv + complex(8), dimension(nbdirsmax,max_size,max_size) :: a_dv + complex(8), dimension(nbdirsmax,max_size,max_size) :: b_dv + ! Declare variables for storing original values + complex(8) :: alpha_orig + complex(8), dimension(nbdirsmax) :: alpha_dv_orig + complex(8), dimension(max_size,max_size) :: a_orig + complex(8), dimension(nbdirsmax,max_size,max_size) :: a_dv_orig + complex(8), dimension(max_size,max_size) :: b_orig + complex(8), dimension(nbdirsmax,max_size,max_size) :: b_dv_orig + + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize test parameters + msize = n + nsize = n + lda_val = lda + ldb_val = ldb + + ! Initialize test data with random numbers + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + call random_number(temp_real) + call random_number(temp_imag) + alpha = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + b(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + + ! Initialize input derivatives to random values (exactly like scalar mode) + do idir = 1, nbdirsmax + call random_number(temp_real) + call random_number(temp_imag) + alpha_dv(idir) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + do idir = 1, nbdirsmax + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a_dv(idir,i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + end do + do idir = 1, nbdirsmax + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + b_dv(idir,i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + end do + + write(*,*) 'Testing ZTRSM (Vector Forward Mode)' + ! Store original values before any function calls (critical for INOUT parameters) + alpha_orig = alpha + alpha_dv_orig = alpha_dv + a_orig = a + a_dv_orig = a_dv + b_orig = b + b_dv_orig = b_dv + + ! Call the vector mode differentiated function + + call ztrsm_dv(side, uplo, transa, diag, msize, nsize, alpha, alpha_dv, a, a_dv, lda_val, b, b_dv, ldb_val, nbdirsmax) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Vector forward mode test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(8), parameter :: h = 1.0e-7 ! Step size for finite differences + real(8) :: relative_error, max_error + real(8) :: abs_error, abs_reference, error_bound + complex(8) :: central_diff, ad_result + integer :: i, j, idir + logical :: has_large_errors + complex(8), dimension(max_size,max_size) :: b_forward, b_backward + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + write(*,*) 'Number of directions:', nbdirsmax + + ! Test each derivative direction separately + do idir = 1, nbdirsmax + + ! Forward perturbation: f(x + h * direction) + alpha = alpha_orig + cmplx(h, 0.0) * alpha_dv_orig(idir) + a = a_orig + cmplx(h, 0.0) * a_dv_orig(idir,:,:) + b = b_orig + cmplx(h, 0.0) * b_dv_orig(idir,:,:) + call ztrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_forward = b + + ! Backward perturbation: f(x - h * direction) + alpha = alpha_orig - cmplx(h, 0.0) * alpha_dv_orig(idir) + a = a_orig - cmplx(h, 0.0) * a_dv_orig(idir,:,:) + b = b_orig - cmplx(h, 0.0) * b_dv_orig(idir,:,:) + call ztrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_backward = b + + ! Compute central differences and compare with AD results + do j = 1, min(2, nsize) ! Check only first few elements + do i = 1, min(2, nsize) + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (b_forward(i,j) - b_backward(i,j)) / (2.0e0 * h) + ! AD result + ad_result = b_dv(idir,i,j) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) ' Large error in direction', idir, ' output B(', i, ',', j, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_ztrsm_vector_forward \ No newline at end of file diff --git a/BLAS/test/test_ztrsm_vector_reverse.f90 b/BLAS/test/test_ztrsm_vector_reverse.f90 new file mode 100644 index 0000000..fac9ce5 --- /dev/null +++ b/BLAS/test/test_ztrsm_vector_reverse.f90 @@ -0,0 +1,285 @@ +! Test program for ZTRSM vector reverse mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision with nbdirsmax=4 + +program test_ztrsm_vector_reverse + implicit none + include 'DIFFSIZES.inc' + + external :: ztrsm + external :: ztrsm_bv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, k ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: side + character :: uplo + character :: transa + character :: diag + integer :: msize + integer :: nsize + complex(8) :: alpha + complex(8), dimension(max_size,max_size) :: a + integer :: lda_val + complex(8), dimension(max_size,max_size) :: b + integer :: ldb_val + + ! Adjoint variables (reverse vector mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + complex(8), dimension(nbdirsmax) :: alphab + complex(8), dimension(nbdirsmax,max_size,max_size) :: ab + complex(8), dimension(nbdirsmax,max_size,max_size) :: bb + + ! Storage for original cotangents (for INOUT parameters in VJP verification) + complex(8), dimension(nbdirsmax,max_size,max_size) :: bb_orig + + ! Storage for original values (for VJP verification) + complex(8) :: alpha_orig + complex(8), dimension(max_size,max_size) :: a_orig + complex(8), dimension(max_size,max_size) :: b_orig + + ! Variables for VJP verification via finite differences + real(8), parameter :: h = 1.0e-7 + real(8) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + real(8), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize primal values + side = 'L' + uplo = 'U' + transa = 'N' + diag = 'N' + msize = n + nsize = n + call random_number(temp_real) + call random_number(temp_imag) + alpha = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + lda_val = lda + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + b(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + ldb_val = ldb + + ! Store original primal values + alpha_orig = alpha + a_orig = a + b_orig = b + + ! Initialize output adjoints (cotangents) with random values for each direction + ! These are the 'seeds' for reverse mode + do k = 1, nbdirsmax + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + bb(k,i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + end do + + ! Initialize input adjoints to zero (they will be computed) + ! Note: Inout parameters are skipped - they already have output adjoints initialized + alphab = 0.0 + ab = 0.0 + + ! Save original cotangent seeds for OUTPUT/INOUT parameters (before function call) + bb_orig = bb + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! ISIZE1OF* (vectors): use n to match adjoint array size; ISIZE2OF* (matrices): use max_size. + call set_ISIZE2OFA(max_size) + + ! Call reverse vector mode differentiated function + call ztrsm_bv(side, uplo, transa, diag, msize, nsize, alpha, alphab, a, ab, lda_val, b, bb, ldb_val, nbdirsmax) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing + complex(8) :: alpha_dir + complex(8), dimension(max_size,max_size) :: a_dir + complex(8), dimension(max_size,max_size) :: b_dir + complex(8), dimension(max_size,max_size) :: b_plus, b_minus, b_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Test each differentiation direction separately + do k = 1, nbdirsmax + + ! Initialize random direction vectors for all inputs + call random_number(temp_real) + call random_number(temp_imag) + alpha_dir = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + a_dir(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + b_dir(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + + ! Forward perturbation: f(x + h*dir) + alpha = alpha_orig + cmplx(h, 0.0) * alpha_dir + a = a_orig + cmplx(h, 0.0) * a_dir + b = b_orig + cmplx(h, 0.0) * b_dir + call ztrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_plus = b + + ! Backward perturbation: f(x - h*dir) + alpha = alpha_orig - cmplx(h, 0.0) * alpha_dir + a = a_orig - cmplx(h, 0.0) * a_dir + b = b_orig - cmplx(h, 0.0) * b_dir + call ztrsm(side, uplo, transa, diag, msize, nsize, alpha, a, lda_val, b, ldb_val) + b_minus = b + + ! Compute central differences and VJP verification + ! VJP check: direction^T @ adjoint should equal finite difference + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + b_central_diff = (b_plus - b_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0d0 + ! Compute and sort products for b (FD) + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(bb_orig(k,i,j)) * b_central_diff(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0d0 + vjp_ad = vjp_ad + real(conjg(alpha_dir) * alphab(k)) + ! Compute and sort products for b + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(b_dir(i,j)) * bb(k,i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(a_dir(i,j)) * ab(k,i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + ! Compute relative error for reporting + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + if (relative_error > max_error) max_error = relative_error + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(8), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(8) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_ztrsm_vector_reverse \ No newline at end of file diff --git a/BLAS/test/test_ztrsv.f90 b/BLAS/test/test_ztrsv.f90 new file mode 100644 index 0000000..8c9a60f --- /dev/null +++ b/BLAS/test/test_ztrsv.f90 @@ -0,0 +1,196 @@ +! Test program for ZTRSV differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision + +program test_ztrsv + implicit none + + integer :: seed_array(33) + + external :: ztrsv + external :: ztrsv_d + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: uplo + character :: trans + character :: diag + integer :: nsize + complex(8), dimension(max_size,max_size) :: a + integer :: lda_val + complex(8), dimension(max_size) :: x + integer :: incx_val + + ! Derivative variables + complex(8), dimension(max_size,max_size) :: a_d + complex(8), dimension(max_size) :: x_d + + ! Storage variables for inout parameters + complex(8), dimension(max_size) :: x_output + + ! Array restoration variables for numerical differentiation + complex(8), dimension(max_size,max_size) :: a_orig + complex(8), dimension(max_size) :: x_orig + + ! Variables for central difference computation + complex(8), dimension(max_size) :: x_forward, x_backward + ! Scalar variables for central difference computation + complex(8) :: central_diff, ad_result + logical :: has_large_errors + + ! Variables for storing original derivative values + complex(8), dimension(max_size) :: x_d_orig + complex(8), dimension(max_size,max_size) :: a_d_orig + + ! Temporary variables for matrix initialization + real(4) :: temp_real, temp_imag + integer :: i, j + + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + lda_val = lda ! LDA must be at least max( 1 + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + x(i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + incx_val = 1 ! INCX 1 + + ! Initialize input derivatives to random values + do i = 1, lda + do j = 1, lda + call random_number(temp_real) + call random_number(temp_imag) + a_d(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + x_d(i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + + ! Store initial derivative values after random initialization + x_d_orig = x_d + a_d_orig = a_d + + ! Store original values for central difference computation + a_orig = a + x_orig = x + + write(*,*) 'Testing ZTRSV' + ! Store input values of inout parameters before first function call + x_orig = x + + ! Re-initialize data for differentiated function + ! Only reinitialize inout parameters - keep input-only parameters unchanged + + ! uplo already has correct value from original call + ! trans already has correct value from original call + ! diag already has correct value from original call + nsize = n + ! a already has correct value from original call + lda_val = lda ! LDA must be at least max( 1 + x = x_orig + incx_val = 1 ! INCX 1 + + ! Call the differentiated function + call ztrsv_d(uplo, trans, diag, nsize, a, a_d, lda_val, x, x_d, incx_val) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(8), parameter :: h = 1.0e-6 ! Step size for finite differences + real(8) :: relative_error, max_error + real(8) :: output_orig, output_pert + real(8) :: numerical_result, analytical_result + real(8) :: abs_error, abs_reference, error_bound + integer :: i, j + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5 + + ! Original values already stored in main program + + ! Central difference computation: f(x + h) - f(x - h) / (2h) + ! Forward perturbation: f(x + h) + a = a_orig + cmplx(h, 0.0) * a_d_orig + x = x_orig + cmplx(h, 0.0) * x_d_orig + call ztrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + ! Store forward perturbation results + x_forward = x + + ! Backward perturbation: f(x - h) + a = a_orig - cmplx(h, 0.0) * a_d_orig + x = x_orig - cmplx(h, 0.0) * x_d_orig + call ztrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + ! Store backward perturbation results + x_backward = x + + ! Compute central differences and compare with AD results + ! Check derivatives for output X + do i = 1, min(2, n) ! Check only first few elements + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (x_forward(i) - x_backward(i)) / (2.0e0 * h) + ! AD result + ad_result = x_d(i) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) 'Large error in output X(', i, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_ztrsv diff --git a/BLAS/test/test_ztrsv_reverse.f90 b/BLAS/test/test_ztrsv_reverse.f90 new file mode 100644 index 0000000..c0c11a5 --- /dev/null +++ b/BLAS/test/test_ztrsv_reverse.f90 @@ -0,0 +1,256 @@ +! Test program for ZTRSV reverse mode (adjoint) differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision +! Verification uses VJP methodology with finite differences + +program test_ztrsv_reverse + implicit none + + integer :: seed_array(33) + + external :: ztrsv + external :: ztrsv_b + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension (rows/cols of matrices) + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + + character :: uplo + character :: trans + character :: diag + integer :: nsize + complex(8), dimension(max_size,max_size) :: a + integer :: lda_val + complex(8), dimension(max_size) :: x + integer :: incx_val + + ! Adjoint variables (reverse mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + complex(8), dimension(max_size,max_size) :: ab + complex(8), dimension(max_size) :: xb + + ! Storage for original values (for VJP verification) + complex(8), dimension(max_size,max_size) :: a_orig + complex(8), dimension(max_size) :: x_orig + + ! Variables for VJP verification via finite differences + complex(8), dimension(max_size) :: x_plus, x_minus + + ! Saved cotangents (output adjoints) for VJP verification + complex(8), dimension(max_size) :: xb_orig + real(8), parameter :: h = 1.0e-7 + real(8) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + integer :: i, j + real(8), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Temporary variables for complex random initialization + real(4) :: temp_real_init, temp_imag_init + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + ! Initialize primal values + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + a(i,j) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + end do + lda_val = lda + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + x(i) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + incx_val = 1 + + ! Store original primal values + a_orig = a + x_orig = x + + write(*,*) 'Testing ZTRSV' + + ! Initialize output adjoints (cotangents) with random values + ! These are the 'seeds' for reverse mode + do i = 1, max_size + call random_number(temp_real_init) + call random_number(temp_imag_init) + xb(i) = cmplx(temp_real_init, temp_imag_init) * (2.0,2.0) - (1.0,1.0) + end do + + ! Save output adjoints (cotangents) for VJP verification + ! Note: output adjoints may be modified by reverse mode function + xb_orig = xb + + ! Initialize input adjoints to zero (they will be computed) + ab = 0.0d0 + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! Differentiated code checks they are set via check_ISIZE*_initialized. + call set_ISIZE2OFA(max_size) + + ! Call reverse mode differentiated function + call ztrsv_b(uplo, trans, diag, nsize, a, ab, lda_val, x, xb, incx_val) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + ! For reverse mode, we verify: cotangent^T @ J @ direction = direction^T @ adjoint + ! Equivalently: cotangent^T @ (f(x+h*dir) - f(x-h*dir))/(2h) should equal dir^T @ computed_adjoint + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Temporary variables for complex random number generation + real(4) :: temp_real, temp_imag + + ! Direction vectors for VJP testing (like tangents in forward mode) + complex(8), dimension(max_size,max_size) :: a_dir + complex(8), dimension(max_size) :: x_dir + + complex(8), dimension(max_size) :: x_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Initialize random direction vectors for all inputs + do j = 1, max_size + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a_dir(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + x_dir(i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + + ! Forward perturbation: f(x + h*dir) + a = a_orig + cmplx(h, 0.0) * a_dir + x = x_orig + cmplx(h, 0.0) * x_dir + call ztrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_plus = x + + ! Backward perturbation: f(x - h*dir) + a = a_orig - cmplx(h, 0.0) * a_dir + x = x_orig - cmplx(h, 0.0) * x_dir + call ztrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_minus = x + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + x_central_diff = (x_plus - x_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0d0 + ! Compute and sort products for x (FD) + n_products = n + do i = 1, n + temp_products(i) = real(conjg(xb_orig(i)) * x_central_diff(i)) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0d0 + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(a_dir(i,j)) * ab(i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for x + n_products = n + do i = 1, n + temp_products(i) = real(conjg(x_dir(i)) * xb(i)) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + max_error = relative_error + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(8), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(8) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_ztrsv_reverse diff --git a/BLAS/test/test_ztrsv_vector_forward.f90 b/BLAS/test/test_ztrsv_vector_forward.f90 new file mode 100644 index 0000000..0111f50 --- /dev/null +++ b/BLAS/test/test_ztrsv_vector_forward.f90 @@ -0,0 +1,176 @@ +! Test program for ZTRSV vector forward mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision with nbdirsmax=4 + +program test_ztrsv_vector_forward + implicit none + include 'DIFFSIZES.inc' + + external :: ztrsv + external :: ztrsv_dv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, idir ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: uplo + character :: trans + character :: diag + integer :: nsize + complex(8), dimension(max_size,max_size) :: a + integer :: lda_val + complex(8), dimension(max_size) :: x + integer :: incx_val + + ! Vector mode derivative variables (type-promoted) + ! Scalars become arrays(nbdirsmax), arrays gain extra dimension + complex(8), dimension(nbdirsmax,max_size,max_size) :: a_dv + complex(8), dimension(nbdirsmax,max_size) :: x_dv + ! Declare variables for storing original values + complex(8), dimension(max_size,max_size) :: a_orig + complex(8), dimension(nbdirsmax,max_size,max_size) :: a_dv_orig + complex(8), dimension(max_size) :: x_orig + complex(8), dimension(nbdirsmax,max_size) :: x_dv_orig + + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize test parameters + nsize = n + lda_val = lda + incx_val = 1 + + ! Initialize test data with random numbers + ! Initialize random seed for reproducible results + seed_array = 42 + call random_seed(put=seed_array) + + uplo = 'U' + trans = 'N' + diag = 'N' + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + x(i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + + ! Initialize input derivatives to random values (exactly like scalar mode) + do idir = 1, nbdirsmax + do i = 1, max_size + do j = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + a_dv(idir,i,j) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + end do + do idir = 1, nbdirsmax + do i = 1, max_size + call random_number(temp_real) + call random_number(temp_imag) + x_dv(idir,i) = cmplx(temp_real, temp_imag) * (2.0,2.0) - (1.0,1.0) + end do + end do + + write(*,*) 'Testing ZTRSV (Vector Forward Mode)' + ! Store original values before any function calls (critical for INOUT parameters) + a_orig = a + a_dv_orig = a_dv + x_orig = x + x_dv_orig = x_dv + + ! Call the vector mode differentiated function + + call ztrsv_dv(uplo, trans, diag, nsize, a, a_dv, lda_val, x, x_dv, incx_val, nbdirsmax) + + ! Print results and compare + write(*,*) 'Function calls completed successfully' + + ! Numerical differentiation check + call check_derivatives_numerically() + + write(*,*) 'Vector forward mode test completed successfully' + +contains + + subroutine check_derivatives_numerically() + implicit none + real(8), parameter :: h = 1.0e-7 ! Step size for finite differences + real(8) :: relative_error, max_error + real(8) :: abs_error, abs_reference, error_bound + complex(8) :: central_diff, ad_result + integer :: i, j, idir + logical :: has_large_errors + complex(8), dimension(max_size) :: x_forward, x_backward + + max_error = 0.0e0 + has_large_errors = .false. + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + write(*,*) 'Number of directions:', nbdirsmax + + ! Test each derivative direction separately + do idir = 1, nbdirsmax + + ! Forward perturbation: f(x + h * direction) + a = a_orig + cmplx(h, 0.0) * a_dv_orig(idir,:,:) + x = x_orig + cmplx(h, 0.0) * x_dv_orig(idir,:) + call ztrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_forward = x + + ! Backward perturbation: f(x - h * direction) + a = a_orig - cmplx(h, 0.0) * a_dv_orig(idir,:,:) + x = x_orig - cmplx(h, 0.0) * x_dv_orig(idir,:) + call ztrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_backward = x + + ! Compute central differences and compare with AD results + do i = 1, min(2, nsize) ! Check only first few elements + ! Central difference: (f(x+h) - f(x-h)) / (2h) + central_diff = (x_forward(i) - x_backward(i)) / (2.0e0 * h) + ! AD result + ad_result = x_dv(idir,i) + ! Error check: |a - b| > atol + rtol * |b| + abs_error = abs(central_diff - ad_result) + abs_reference = abs(ad_result) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + relative_error = abs_error / max(abs_reference, 1.0e-10) + write(*,*) ' Large error in direction', idir, ' output X(', i, '):' + write(*,*) ' Central diff: ', central_diff + write(*,*) ' AD result: ', ad_result + write(*,*) ' Absolute error:', abs_error + write(*,*) ' Error bound:', error_bound + write(*,*) ' Relative error:', relative_error + end if + ! Track max error for reporting (normalized) + relative_error = abs_error / max(abs_reference, 1.0e-10) + max_error = max(max_error, relative_error) + end do + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_derivatives_numerically + +end program test_ztrsv_vector_forward \ No newline at end of file diff --git a/BLAS/test/test_ztrsv_vector_reverse.f90 b/BLAS/test/test_ztrsv_vector_reverse.f90 new file mode 100644 index 0000000..36f4086 --- /dev/null +++ b/BLAS/test/test_ztrsv_vector_reverse.f90 @@ -0,0 +1,254 @@ +! Test program for ZTRSV vector reverse mode differentiation +! Generated automatically by run_tapenade_blas.py +! Using REAL*8 precision with nbdirsmax=4 + +program test_ztrsv_vector_reverse + implicit none + include 'DIFFSIZES.inc' + + external :: ztrsv + external :: ztrsv_bv + + ! Test parameters + integer, parameter :: n = 4 ! Matrix/vector size for test + integer, parameter :: max_size = n ! Maximum array dimension + integer, parameter :: lda = max_size, ldb = max_size, ldc = max_size ! Leading dimensions + integer :: i, j, k ! Loop counters + integer :: seed_array(33) ! Random seed + real(4) :: temp_real, temp_imag ! Temporary variables for complex initialization + + character :: uplo + character :: trans + character :: diag + integer :: nsize + complex(8), dimension(max_size,max_size) :: a + integer :: lda_val + complex(8), dimension(max_size) :: x + integer :: incx_val + + ! Adjoint variables (reverse vector mode) + ! In reverse mode: output adjoints are INPUT (cotangents/seeds) + ! input adjoints are OUTPUT (computed gradients) + complex(8), dimension(nbdirsmax,max_size,max_size) :: ab + complex(8), dimension(nbdirsmax,max_size) :: xb + + ! Storage for original cotangents (for INOUT parameters in VJP verification) + complex(8), dimension(nbdirsmax,max_size) :: xb_orig + + ! Storage for original values (for VJP verification) + complex(8), dimension(max_size,max_size) :: a_orig + complex(8), dimension(max_size) :: x_orig + + ! Variables for VJP verification via finite differences + real(8), parameter :: h = 1.0e-7 + real(8) :: vjp_ad, vjp_fd, relative_error, max_error, abs_error, abs_reference, error_bound + logical :: has_large_errors + real(8), dimension(max_size*max_size) :: temp_products ! For sorted summation + integer :: n_products + + ! Initialize random seed for reproducibility + seed_array = 42 + call random_seed(put=seed_array) + + + ! Initialize primal values + uplo = 'U' + trans = 'N' + diag = 'N' + nsize = n + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + a(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + lda_val = lda + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + x(i) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + incx_val = 1 + + ! Store original primal values + a_orig = a + x_orig = x + + ! Initialize output adjoints (cotangents) with random values for each direction + ! These are the 'seeds' for reverse mode + do k = 1, nbdirsmax + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + xb(k,i) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + + ! Initialize input adjoints to zero (they will be computed) + ! Note: Inout parameters are skipped - they already have output adjoints initialized + ab = 0.0 + + ! Save original cotangent seeds for OUTPUT/INOUT parameters (before function call) + xb_orig = xb + + ! Set ISIZE globals required by differentiated routine (dimension 2 of arrays). + ! ISIZE1OF* (vectors): use n to match adjoint array size; ISIZE2OF* (matrices): use max_size. + call set_ISIZE2OFA(max_size) + + ! Call reverse vector mode differentiated function + call ztrsv_bv(uplo, trans, diag, nsize, a, ab, lda_val, x, xb, incx_val, nbdirsmax) + + ! Reset ISIZE globals to uninitialized (-1) for completeness + call set_ISIZE2OFA(-1) + + ! VJP Verification using finite differences + call check_vjp_numerically() + + write(*,*) '' + write(*,*) 'Test completed successfully' + +contains + + subroutine check_vjp_numerically() + implicit none + + ! Direction vectors for VJP testing + complex(8), dimension(max_size,max_size) :: a_dir + complex(8), dimension(max_size) :: x_dir + complex(8), dimension(max_size) :: x_plus, x_minus, x_central_diff + + max_error = 0.0d0 + has_large_errors = .false. + + write(*,*) 'Function calls completed successfully' + + write(*,*) 'Checking derivatives against numerical differentiation:' + write(*,*) 'Step size h =', h + + ! Test each differentiation direction separately + do k = 1, nbdirsmax + + ! Initialize random direction vectors for all inputs + do j = 1, n + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + a_dir(i,j) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + end do + do i = 1, n + call random_number(temp_real) + call random_number(temp_imag) + x_dir(i) = cmplx(temp_real * 2.0 - 1.0, temp_imag * 2.0 - 1.0) + end do + + ! Forward perturbation: f(x + h*dir) + a = a_orig + cmplx(h, 0.0) * a_dir + x = x_orig + cmplx(h, 0.0) * x_dir + call ztrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_plus = x + + ! Backward perturbation: f(x - h*dir) + a = a_orig - cmplx(h, 0.0) * a_dir + x = x_orig - cmplx(h, 0.0) * x_dir + call ztrsv(uplo, trans, diag, nsize, a, lda_val, x, incx_val) + x_minus = x + + ! Compute central differences and VJP verification + ! VJP check: direction^T @ adjoint should equal finite difference + + ! Compute central differences: (f(x+h*dir) - f(x-h*dir)) / (2h) + x_central_diff = (x_plus - x_minus) / (2.0d0 * h) + + ! VJP verification: + ! cotangent^T @ central_diff should equal direction^T @ computed_adjoint + ! Left side: cotangent^T @ Jacobian @ direction (via finite differences, with sorted summation) + vjp_fd = 0.0d0 + ! Compute and sort products for x (FD) + n_products = n + do i = 1, n + temp_products(i) = real(conjg(xb_orig(k,i)) * x_central_diff(i)) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_fd = vjp_fd + temp_products(i) + end do + + ! Right side: direction^T @ computed_adjoint (with sorted summation) + ! For INOUT parameters: use cb directly (it contains the computed input adjoint after reverse pass) + ! For pure inputs: use adjoint directly + vjp_ad = 0.0d0 + ! Compute and sort products for a + n_products = 0 + do j = 1, n + do i = 1, n + n_products = n_products + 1 + temp_products(n_products) = real(conjg(a_dir(i,j)) * ab(k,i,j)) + end do + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + ! Compute and sort products for x + n_products = n + do i = 1, n + temp_products(i) = real(conjg(x_dir(i)) * xb(k,i)) + end do + call sort_array(temp_products, n_products) + do i = 1, n_products + vjp_ad = vjp_ad + temp_products(i) + end do + + ! Error check: |vjp_fd - vjp_ad| > atol + rtol * |vjp_ad| + abs_error = abs(vjp_fd - vjp_ad) + abs_reference = abs(vjp_ad) + error_bound = 1.0e-5 + 1.0e-5 * abs_reference + if (abs_error > error_bound) then + has_large_errors = .true. + end if + + ! Compute relative error for reporting + if (abs_reference > 1.0e-10) then + relative_error = abs_error / abs_reference + else + relative_error = abs_error + end if + if (relative_error > max_error) max_error = relative_error + end do + + write(*,*) 'Maximum relative error:', max_error + write(*,*) 'Tolerance thresholds: rtol=1.0e-5, atol=1.0e-5' + if (has_large_errors) then + write(*,*) 'FAIL: Derivatives are outside tolerance' + else + write(*,*) 'PASS: Derivatives are within tolerance (rtol + atol)' + end if + + end subroutine check_vjp_numerically + + subroutine sort_array(arr, n) + implicit none + integer, intent(in) :: n + real(8), dimension(n), intent(inout) :: arr + integer :: i, j, min_idx + real(8) :: temp + + ! Simple selection sort + do i = 1, n-1 + min_idx = i + do j = i+1, n + if (abs(arr(j)) < abs(arr(min_idx))) then + min_idx = j + end if + end do + if (min_idx /= i) then + temp = arr(i) + arr(i) = arr(min_idx) + arr(min_idx) = temp + end if + end do + end subroutine sort_array + +end program test_ztrsv_vector_reverse \ No newline at end of file From 080535ca34be15bf2ff50b0faca56d76f569ec6f Mon Sep 17 00:00:00 2001 From: Shreyas911 Date: Sun, 23 Aug 2026 18:34:55 -0500 Subject: [PATCH 6/6] Minor formatting changes and adding (had forgotten) Giles method code for strsm. --- BLAS/src/dtrsm_b.f | 1 + BLAS/src/dtrsm_d.f | 4 +- BLAS/src/dtrsm_dv.f | 1 + BLAS/src/dtrsv_b.f | 10 +- BLAS/src/dtrsv_bv.f | 8 +- BLAS/src/dtrsv_d.f | 15 +- BLAS/src/strsm_b.f | 21 +- BLAS/src/strsm_bv.f | 15 +- BLAS/src/strsm_d.f | 11 +- BLAS/src/strsm_dv.f | 14 +- BLAS/src/strsv_b.f | 1054 +++++++++++++------------ BLAS/src/strsv_bv.f | 1261 ++++++++++++++++-------------- BLAS/src/strsv_d.f | 531 +++++++------ BLAS/src/strsv_dv.f | 692 ++++++++-------- BLAS/test/test_strsm_reverse.f90 | 1 - 15 files changed, 1973 insertions(+), 1666 deletions(-) diff --git a/BLAS/src/dtrsm_b.f b/BLAS/src/dtrsm_b.f index 79bbe86..711ef54 100644 --- a/BLAS/src/dtrsm_b.f +++ b/BLAS/src/dtrsm_b.f @@ -903,3 +903,4 @@ SUBROUTINE DTRSM_B(SIDE, UPLO, TRANSA, DIAG, M, N, RETURN END SUBROUTINE DTRSM_B + diff --git a/BLAS/src/dtrsm_d.f b/BLAS/src/dtrsm_d.f index 9757b5b..17abbd2 100644 --- a/BLAS/src/dtrsm_d.f +++ b/BLAS/src/dtrsm_d.f @@ -483,8 +483,8 @@ SUBROUTINE DTRSM_D(SIDE, UPLO, TRANSA, DIAG, M, N, + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB) C C Forward-mode derivative of DTRSM via the black-box / Giles-style -C approach: uses ONLY the original, undifferentiated -C DTRSM and DTRMM -- no hand-differentiated loops. +C approach: differentiate op(A)*X = alpha*B directly. Uses only the +C original DTRSM and DTRMM. C IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG diff --git a/BLAS/src/dtrsm_dv.f b/BLAS/src/dtrsm_dv.f index 9c91a3e..69a3270 100644 --- a/BLAS/src/dtrsm_dv.f +++ b/BLAS/src/dtrsm_dv.f @@ -635,3 +635,4 @@ SUBROUTINE DTRSM_DV(SIDE, UPLO, TRANSA, DIAG, M, N, RETURN END SUBROUTINE DTRSM_DV + diff --git a/BLAS/src/dtrsv_b.f b/BLAS/src/dtrsv_b.f index bf569d8..f27d05b 100644 --- a/BLAS/src/dtrsv_b.f +++ b/BLAS/src/dtrsv_b.f @@ -644,11 +644,11 @@ C END SUBROUTINE DTRSV_B(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, INCX) -! -! Reverse-mode (adjoint) derivative of DTRSV, black-box/Giles-style. -! X is read-only (original entry RHS), never written -- matches the -! net externally-visible behavior of Tapenade's own dtrsv_b.f. -! +C +C Reverse-mode (adjoint) derivative of DTRSV, black-box/Giles-style. +C X is read-only (original entry RHS), never written -- matches the +C net externally-visible behavior of Tapenade's own dtrsv_b.f. +C IMPLICIT NONE CHARACTER UPLO, TRANS, DIAG INTEGER N, LDA, INCX diff --git a/BLAS/src/dtrsv_bv.f b/BLAS/src/dtrsv_bv.f index 903bf2c..1244681 100644 --- a/BLAS/src/dtrsv_bv.f +++ b/BLAS/src/dtrsv_bv.f @@ -740,10 +740,10 @@ SUBROUTINE DTRSV_BV(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, + INCX, NBDIRS) -! -! Vector reverse-mode (adjoint) derivative of DTRSV, black-box/Giles-style. -! Self-contained -- does not call DTRSV_B. -! +C +C Vector reverse-mode (adjoint) derivative of DTRSV, black-box/Giles-style. +C Self-contained -- does not call DTRSV_B. +C IMPLICIT NONE INCLUDE 'DIFFSIZES.inc' CHARACTER UPLO, TRANS, DIAG diff --git a/BLAS/src/dtrsv_d.f b/BLAS/src/dtrsv_d.f index ca9ee5f..2ea7e17 100644 --- a/BLAS/src/dtrsv_d.f +++ b/BLAS/src/dtrsv_d.f @@ -390,12 +390,15 @@ C END SUBROUTINE DTRSV_D(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, INCX) -! -! Forward-mode derivative of DTRSV, black-box/Giles-style: differentiate -! op(A)*s = b directly. Uses only the original DTRSV and DTRMV. -! X, XD are overwritten in place with the solution and its derivative, -! matching the primal DTRSV's own convention. -! +C +C Forward-mode derivative of STRSV via the black-box / Giles-style +C approach: differentiate op(A)*s = b directly (the exact vector case +C from the Giles appendix). Uses only the original STRSV and STRMV. +C +C CONVENTION (matches the primal STRSV's own in-place behavior): +C X, XD : overwritten in place with the solution S and its +C derivative dS, exactly like the primal/forward routine. +C IMPLICIT NONE CHARACTER UPLO, TRANS, DIAG INTEGER N, LDA, INCX diff --git a/BLAS/src/strsm_b.f b/BLAS/src/strsm_b.f index 76115ef..6eab8ff 100644 --- a/BLAS/src/strsm_b.f +++ b/BLAS/src/strsm_b.f @@ -791,15 +791,17 @@ SUBROUTINE STRSM_B(SIDE, UPLO, TRANSA, DIAG, M, N, + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB) -! -! Reverse-mode (adjoint) derivative of STRSM via the Giles/black-box -! method. Uses only the original STRSM. -! -! CONVENTION: -! B : untouched, original forward-call input. -! BB : IN = seed adjoint dF/dX; OUT = adjoint dF/dB (in place). -! ALPHAB, AB : OUTPUT ONLY -- zeroed and filled here. -! +C +C Reverse-mode (adjoint) derivative of STRSM via the Giles/black-box +C method: differentiates op(A)*X = alpha*B directly, using only the +C original, undifferentiated STRSM -- never the substitution algorithm. +C +C CONVENTION (matches Tapenade's own generated strsm_b.f): +C B : untouched, original forward-call input. +C BB : IN = seed adjoint dF/dX; OUT = adjoint dF/dB (in place). +C ALPHAB, AB : OUTPUT ONLY -- zeroed and filled here, not accumulated +C into whatever the caller passed in. +C IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB @@ -828,6 +830,7 @@ SUBROUTINE STRSM_B(SIDE, UPLO, TRANSA, DIAG, M, N, END IF C Step 1: Yb solves op(A)^T*Yb = Xb (SIDE='L') or Yb*op(A)^T = Xb (SIDE='R') +C Overwrites BB in place: held the seed on entry, holds Yb after. CALL STRSM(SIDE, UPLO, TRANSA_T, DIAG, M, N, 1.0E0, A, LDA, BB, LDB) C Step 2: recompute X from the ORIGINAL, untouched B diff --git a/BLAS/src/strsm_bv.f b/BLAS/src/strsm_bv.f index da12372..135c25b 100644 --- a/BLAS/src/strsm_bv.f +++ b/BLAS/src/strsm_bv.f @@ -901,10 +901,17 @@ SUBROUTINE STRSM_BV(SIDE, UPLO, TRANSA, DIAG, M, N, + ALPHA, ALPHAB, A, AB, LDA, B, BB, LDB, NBDIRS) -! -! Vector reverse-mode (adjoint) derivative of STRSM, black-box/Giles-style. -! Self-contained -- does not call STRSM_B. -! +C +C Vector reverse-mode (adjoint) derivative of STRSM, black-box/Giles-style. +C Self-contained -- does not call STRSM_B. AB/BB store direction as the +C FASTEST-varying index (nbdirsmax, LDA/LDB, *): gather each direction into +C a plain work array before use, scatter the result back after. +C +C CONVENTION (matches Tapenade's strsm_bv.f): +C B : untouched, original forward-call input. +C BB : IN = seed adjoints (one per direction); OUT = dF/dB. +C ALPHAB, AB : OUTPUT ONLY, zeroed and filled here per direction. +C IMPLICIT NONE INCLUDE 'DIFFSIZES.inc' CHARACTER SIDE, UPLO, TRANSA, DIAG diff --git a/BLAS/src/strsm_d.f b/BLAS/src/strsm_d.f index 06800f4..08c6821 100644 --- a/BLAS/src/strsm_d.f +++ b/BLAS/src/strsm_d.f @@ -481,11 +481,11 @@ SUBROUTINE STRSM_D(SIDE, UPLO, TRANSA, DIAG, M, N, + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB) -! -! Forward-mode derivative of STRSM via the black-box / Giles-style -! approach: differentiate op(A)*X = alpha*B directly. Uses only the -! original STRSM and STRMM. -! +C +C Forward-mode derivative of STRSM via the black-box / Giles-style +C approach: differentiate op(A)*X = alpha*B directly. Uses only the +C original STRSM and STRMM. +C IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB @@ -499,6 +499,7 @@ SUBROUTINE STRSM_D(SIDE, UPLO, TRANSA, DIAG, M, N, IF (M.EQ.0 .OR. N.EQ.0) RETURN C Step 1: X = solution of the original forward call +C (private copy -- B itself must stay untouched) DO J = 1, N DO I = 1, M X(I,J) = B(I,J) diff --git a/BLAS/src/strsm_dv.f b/BLAS/src/strsm_dv.f index 8fa8c02..f2003d2 100644 --- a/BLAS/src/strsm_dv.f +++ b/BLAS/src/strsm_dv.f @@ -556,12 +556,14 @@ SUBROUTINE STRSM_DV(SIDE, UPLO, TRANSA, DIAG, M, N, + ALPHA, ALPHAD, A, AD, LDA, B, BD, LDB, NBDIRS) -! -! Vector forward-mode derivative of STRSM (black-box/Giles-style). -! Self-contained -- does not call STRSM_D. AD/BD store direction as -! the FASTEST-varying index (nbdirsmax, LDA/LDB, *): gather each -! direction into a plain work array before use, scatter back after. -! +C +C Vector forward-mode derivative of STRSM (black-box / Giles-style): +C differentiates op(A)*X = alpha*B directly, using only the original +C STRSM and STRMM. Self-contained, does not call STRSM_D. +C +C AD/BD store direction as the FASTEST-varying index (nbdirsmax, LDA/LDB, *), +C so each direction's slice is gathered into a plain work array before use. +C IMPLICIT NONE INCLUDE 'DIFFSIZES.inc' CHARACTER SIDE, UPLO, TRANSA, DIAG diff --git a/BLAS/src/strsv_b.f b/BLAS/src/strsv_b.f index 862763c..0708d58 100644 --- a/BLAS/src/strsv_b.f +++ b/BLAS/src/strsv_b.f @@ -152,500 +152,576 @@ C> \endverbatim C> C ===================================================================== - SUBROUTINE STRSV_B(uplo, trans, diag, n, a, ab, lda, x, xb, incx) - IMPLICIT NONE - INCLUDE 'DIFFSIZES.inc' -C Hint: ISIZE2OFa should be the size of dimension 2 of array a -C -C -- Reference BLAS level2 routine -- -C -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -C -C .. Scalar Arguments .. - INTEGER incx, lda, n - CHARACTER diag, trans, uplo -C .. -C .. Array Arguments .. - REAL a(lda, *), x(*) - REAL ab(lda, *), xb(*) -C .. -C -C ===================================================================== -C .. -C .. Local Scalars .. - REAL temp - REAL tempb - INTEGER i, info, ix, j, jx, kx - LOGICAL nounit - EXTERNAL LSAME - INTEGER ISIZE2OFA -C .. -C .. External Functions .. - INTEGER get_ISIZE2OFA - EXTERNAL get_ISIZE2OFA - LOGICAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, check_ISIZE2OFA_initialized -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX - INTEGER max1 - REAL tempb0 - INTEGER ad_from - INTEGER*4 branch - INTEGER ad_from0 - INTEGER ad_from1 - INTEGER ad_from2 - INTEGER ad_to - INTEGER ad_to0 - INTEGER ad_to1 - INTEGER ad_to2 - INTEGER ii2 - INTEGER ii1 -C .. +C SUBROUTINE STRSV_B(uplo, trans, diag, n, a, ab, lda, x, xb, incx) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C REAL a(lda, *), x(*) +C REAL ab(lda, *), xb(*) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C REAL temp +C REAL tempb +C INTEGER i, info, ix, j, jx, kx +C LOGICAL nounit +C EXTERNAL LSAME +C INTEGER ISIZE2OFA +CC .. +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +C INTEGER max1 +C REAL tempb0 +C INTEGER ad_from +C INTEGER*4 branch +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_from2 +C INTEGER ad_to +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_to2 +C INTEGER ii2 +C INTEGER ii1 +CC .. +CC +CC Test the input parameters. +CC +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(4) +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 8 +C ELSE +C CALL PUSHCONTROL3B(5) +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (n .EQ. 0) THEN +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ELSE +CC +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C CALL PUSHCONTROL1B(0) +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C CALL PUSHCONTROL1B(1) +C kx = 1 +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL4(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(temp) +C temp = x(j) +C ad_from = j - 1 +C DO i=ad_from,1,-1 +C CALL PUSHREAL4(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C tempb = 0.0 +C CALL POPINTEGER4(ad_from) +C DO i=1,ad_from,1 +C CALL POPREAL4(x(i)) +C tempb = tempb - a(i, j)*xb(i) +C ab(i, j) = ab(i, j) - temp*xb(i) +C ENDDO +C CALL POPREAL4(temp) +C xb(j) = xb(j) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(x(j)) +C tempb0 = xb(j)/a(j, j) +C xb(j) = tempb0 +C ab(j, j) = ab(j, j) - x(j)*tempb0/a(j, j) +C END IF +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL4(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from0 = j - 1 +C DO i=ad_from0,1,-1 +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C CALL PUSHREAL4(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C tempb = 0.0 +C CALL POPINTEGER4(ad_from0) +C DO i=1,ad_from0,1 +C CALL POPREAL4(x(ix)) +C tempb = tempb - a(i, j)*xb(ix) +C ab(i, j) = ab(i, j) - temp*xb(ix) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPREAL4(temp) +C xb(jx) = xb(jx) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(x(jx)) +C tempb0 = xb(jx)/a(j, j) +C xb(jx) = tempb0 +C ab(j, j) = ab(j, j) - x(jx)*tempb0/a(j, j) +C END IF +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHREAL4(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(temp) +C temp = x(j) +C ad_from1 = j + 1 +C DO i=ad_from1,n +C CALL PUSHREAL4(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C tempb = 0.0 +C CALL POPINTEGER4(ad_from1) +C DO i=n,ad_from1,-1 +C CALL POPREAL4(x(i)) +C tempb = tempb - a(i, j)*xb(i) +C ab(i, j) = ab(i, j) - temp*xb(i) +C ENDDO +C CALL POPREAL4(temp) +C xb(j) = xb(j) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(x(j)) +C tempb0 = xb(j)/a(j, j) +C xb(j) = tempb0 +C ab(j, j) = ab(j, j) - x(j)*tempb0/a(j, j) +C END IF +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHREAL4(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from2 = j + 1 +C DO i=ad_from2,n +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C CALL PUSHREAL4(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C tempb = 0.0 +C CALL POPINTEGER4(ad_from2) +C DO i=n,ad_from2,-1 +C CALL POPREAL4(x(ix)) +C tempb = tempb - a(i, j)*xb(ix) +C ab(i, j) = ab(i, j) - temp*xb(ix) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPREAL4(temp) +C xb(jx) = xb(jx) + tempb +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(x(jx)) +C tempb0 = xb(jx)/a(j, j) +C xb(jx) = tempb0 +C ab(j, j) = ab(j, j) - x(jx)*tempb0/a(j, j) +C END IF +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C temp = x(j) +C DO i=1,j-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPREAL4(x(j)) +C tempb = xb(j) +C xb(j) = 0.0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C tempb0 = tempb/a(j, j) +C tempb = tempb0 +C ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) +C END IF +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C ab(i, j) = ab(i, j) - x(i)*tempb +C xb(i) = xb(i) - a(i, j)*tempb +C ENDDO +C xb(j) = xb(j) + tempb +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C temp = x(jx) +C ix = kx +C DO i=1,j-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C CALL POPREAL4(x(jx)) +C tempb = xb(jx) +C xb(jx) = 0.0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C tempb0 = tempb/a(j, j) +C tempb = tempb0 +C ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) +C END IF +C CALL POPINTEGER4(ad_to0) +C DO i=ad_to0,1,-1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) - x(ix)*tempb +C xb(ix) = xb(ix) - a(i, j)*tempb +C ENDDO +C xb(jx) = xb(jx) + tempb +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C temp = x(j) +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPREAL4(x(j)) +C tempb = xb(j) +C xb(j) = 0.0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C tempb0 = tempb/a(j, j) +C tempb = tempb0 +C ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) +C END IF +C CALL POPINTEGER4(ad_to1) +C DO i=ad_to1,n,1 +C ab(i, j) = ab(i, j) - x(i)*tempb +C xb(i) = xb(i) - a(i, j)*tempb +C ENDDO +C xb(j) = xb(j) + tempb +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C temp = x(jx) +C ix = kx +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C ab(ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C CALL POPREAL4(x(jx)) +C tempb = xb(jx) +C xb(jx) = 0.0 +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C tempb0 = tempb/a(j, j) +C tempb = tempb0 +C ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) +C END IF +C CALL POPINTEGER4(ad_to2) +C DO i=ad_to2,n,1 +C CALL POPINTEGER4(ix) +C ab(i, j) = ab(i, j) - x(ix)*tempb +C xb(ix) = xb(ix) - a(i, j)*tempb +C ENDDO +C xb(jx) = xb(jx) + tempb +C ENDDO +C END IF +C CALL POPCONTROL1B(branch) +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE STRSV_B(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, INCX) C -C Test the input parameters. +C Reverse-mode (adjoint) derivative of STRSV, black-box/Giles-style. +C X is read-only (original entry RHS), never written -- matches the +C net externally-visible behavior of Tapenade's own strsv_b.f. C - CALL check_ISIZE2OFA_initialized() - ISIZE2OFA = get_ISIZE2OFA() - info = 0 - IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN - CALL PUSHCONTROL3B(0) - info = 1 - ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) - + .AND. (.NOT.LSAME(trans, 'C'))) THEN - CALL PUSHCONTROL3B(1) - info = 2 - ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN - CALL PUSHCONTROL3B(2) - info = 3 - ELSE IF (n .LT. 0) THEN - CALL PUSHCONTROL3B(3) - info = 4 + IMPLICIT NONE + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX + REAL A(LDA,*), AB(LDA,*) + REAL X(*), XB(*) + + REAL BLOC(N), S(N), YB(N) + CHARACTER TRANS_T + LOGICAL UPPER, UNIT, NOTRANS + INTEGER I, J, KX + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 ELSE - IF (1 .LT. n) THEN - max1 = n - ELSE - max1 = 1 - END IF - IF (lda .LT. max1) THEN - CALL PUSHCONTROL3B(4) - info = 6 - ELSE IF (incx .EQ. 0) THEN - CALL PUSHCONTROL3B(5) - info = 8 - ELSE - CALL PUSHCONTROL3B(5) - END IF + KX = 1 - (N-1)*INCX END IF - IF (info .EQ. 0) THEN -C -C Quick return if possible. -C - IF (n .EQ. 0) THEN - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - ELSE -C - nounit = LSAME(diag, 'N') -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF (incx .LE. 0) THEN - CALL PUSHCONTROL1B(0) - kx = 1 - (n-1)*incx - ELSE IF (incx .NE. 1) THEN - CALL PUSHCONTROL1B(1) - kx = 1 - ELSE - CALL PUSHCONTROL1B(1) - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF (LSAME(trans, 'N')) THEN -C -C Form x := inv( A )*x. -C - IF (LSAME(uplo, 'U')) THEN - IF (incx .EQ. 1) THEN - DO j=n,1,-1 - IF (nounit) THEN - CALL PUSHREAL4(x(j)) - x(j) = x(j)/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(temp) - temp = x(j) - ad_from = j - 1 - DO i=ad_from,1,-1 - CALL PUSHREAL4(x(i)) - x(i) = x(i) - temp*a(i, j) - ENDDO - CALL PUSHINTEGER4(ad_from) - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - DO j=1,n,1 - tempb = 0.0 - CALL POPINTEGER4(ad_from) - DO i=1,ad_from,1 - CALL POPREAL4(x(i)) - tempb = tempb - a(i, j)*xb(i) - ab(i, j) = ab(i, j) - temp*xb(i) - ENDDO - CALL POPREAL4(temp) - xb(j) = xb(j) + tempb - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(x(j)) - tempb0 = xb(j)/a(j, j) - xb(j) = tempb0 - ab(j, j) = ab(j, j) - x(j)*tempb0/a(j, j) - END IF - ENDDO - ELSE - jx = kx + (n-1)*incx - DO j=n,1,-1 - IF (nounit) THEN - CALL PUSHREAL4(x(jx)) - x(jx) = x(jx)/a(j, j) - CALL PUSHCONTROL1B(0) + + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + NOTRANS = (TRANS.EQ.'N' .OR. TRANS.EQ.'n') + IF (NOTRANS) THEN + TRANS_T = 'T' + ELSE + TRANS_T = 'N' + END IF + + DO I = 1, N + BLOC(I) = X(KX + (I-1)*INCX) + YB(I) = XB(KX + (I-1)*INCX) + END DO + +C Yb solves op(A)^T*Yb = Xb + CALL STRSV(UPLO, TRANS_T, DIAG, N, A, LDA, YB, 1) + +C Recompute S from the original, untouched B + DO I = 1, N + S(I) = BLOC(I) + END DO + CALL STRSV(UPLO, TRANS, DIAG, N, A, LDA, S, 1) + + DO J = 1, LDA + DO I = 1, LDA + AB(I,J) = 0.0E0 + END DO + END DO + + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J) .OR. (.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + AB(I,J) = -YB(I)*S(J) ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(temp) - temp = x(jx) - CALL PUSHINTEGER4(ix) - ix = jx - ad_from0 = j - 1 - DO i=ad_from0,1,-1 - CALL PUSHINTEGER4(ix) - ix = ix - incx - CALL PUSHREAL4(x(ix)) - x(ix) = x(ix) - temp*a(i, j) - ENDDO - CALL PUSHINTEGER4(ad_from0) - CALL PUSHINTEGER4(jx) - jx = jx - incx - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - DO j=1,n,1 - CALL POPINTEGER4(jx) - tempb = 0.0 - CALL POPINTEGER4(ad_from0) - DO i=1,ad_from0,1 - CALL POPREAL4(x(ix)) - tempb = tempb - a(i, j)*xb(ix) - ab(i, j) = ab(i, j) - temp*xb(ix) - CALL POPINTEGER4(ix) - ENDDO - CALL POPINTEGER4(ix) - CALL POPREAL4(temp) - xb(jx) = xb(jx) + tempb - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(x(jx)) - tempb0 = xb(jx)/a(j, j) - xb(jx) = tempb0 - ab(j, j) = ab(j, j) - x(jx)*tempb0/a(j, j) + AB(I,J) = -S(I)*YB(J) END IF - ENDDO - END IF - ELSE IF (incx .EQ. 1) THEN - DO j=1,n - IF (nounit) THEN - CALL PUSHREAL4(x(j)) - x(j) = x(j)/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(temp) - temp = x(j) - ad_from1 = j + 1 - DO i=ad_from1,n - CALL PUSHREAL4(x(i)) - x(i) = x(i) - temp*a(i, j) - ENDDO - CALL PUSHINTEGER4(ad_from1) - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - DO j=n,1,-1 - tempb = 0.0 - CALL POPINTEGER4(ad_from1) - DO i=n,ad_from1,-1 - CALL POPREAL4(x(i)) - tempb = tempb - a(i, j)*xb(i) - ab(i, j) = ab(i, j) - temp*xb(i) - ENDDO - CALL POPREAL4(temp) - xb(j) = xb(j) + tempb - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(x(j)) - tempb0 = xb(j)/a(j, j) - xb(j) = tempb0 - ab(j, j) = ab(j, j) - x(j)*tempb0/a(j, j) - END IF - ENDDO - ELSE - jx = kx - DO j=1,n - IF (nounit) THEN - CALL PUSHREAL4(x(jx)) - x(jx) = x(jx)/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(temp) - temp = x(jx) - CALL PUSHINTEGER4(ix) - ix = jx - ad_from2 = j + 1 - DO i=ad_from2,n - CALL PUSHINTEGER4(ix) - ix = ix + incx - CALL PUSHREAL4(x(ix)) - x(ix) = x(ix) - temp*a(i, j) - ENDDO - CALL PUSHINTEGER4(ad_from2) - CALL PUSHINTEGER4(jx) - jx = jx + incx - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - DO j=n,1,-1 - CALL POPINTEGER4(jx) - tempb = 0.0 - CALL POPINTEGER4(ad_from2) - DO i=n,ad_from2,-1 - CALL POPREAL4(x(ix)) - tempb = tempb - a(i, j)*xb(ix) - ab(i, j) = ab(i, j) - temp*xb(ix) - CALL POPINTEGER4(ix) - ENDDO - CALL POPINTEGER4(ix) - CALL POPREAL4(temp) - xb(jx) = xb(jx) + tempb - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(x(jx)) - tempb0 = xb(jx)/a(j, j) - xb(jx) = tempb0 - ab(j, j) = ab(j, j) - x(jx)*tempb0/a(j, j) - END IF - ENDDO + END IF END IF - ELSE IF (LSAME(uplo, 'U')) THEN -C -C Form x := inv( A**T )*x. -C - IF (incx .EQ. 1) THEN - DO j=1,n - temp = x(j) - DO i=1,j-1 - temp = temp - a(i, j)*x(i) - ENDDO - CALL PUSHINTEGER4(i - 1) - IF (nounit) THEN - CALL PUSHREAL4(temp) - temp = temp/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(x(j)) - x(j) = temp - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - DO j=n,1,-1 - CALL POPREAL4(x(j)) - tempb = xb(j) - xb(j) = 0.0 - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(temp) - tempb0 = tempb/a(j, j) - tempb = tempb0 - ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) - END IF - CALL POPINTEGER4(ad_to) - DO i=ad_to,1,-1 - ab(i, j) = ab(i, j) - x(i)*tempb - xb(i) = xb(i) - a(i, j)*tempb - ENDDO - xb(j) = xb(j) + tempb - ENDDO - ELSE - jx = kx - DO j=1,n - temp = x(jx) - ix = kx - DO i=1,j-1 - temp = temp - a(i, j)*x(ix) - CALL PUSHINTEGER4(ix) - ix = ix + incx - ENDDO - CALL PUSHINTEGER4(i - 1) - IF (nounit) THEN - CALL PUSHREAL4(temp) - temp = temp/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(x(jx)) - x(jx) = temp - CALL PUSHINTEGER4(jx) - jx = jx + incx - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - DO j=n,1,-1 - CALL POPINTEGER4(jx) - CALL POPREAL4(x(jx)) - tempb = xb(jx) - xb(jx) = 0.0 - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(temp) - tempb0 = tempb/a(j, j) - tempb = tempb0 - ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) - END IF - CALL POPINTEGER4(ad_to0) - DO i=ad_to0,1,-1 - CALL POPINTEGER4(ix) - ab(i, j) = ab(i, j) - x(ix)*tempb - xb(ix) = xb(ix) - a(i, j)*tempb - ENDDO - xb(jx) = xb(jx) + tempb - ENDDO - END IF - ELSE IF (incx .EQ. 1) THEN - DO j=n,1,-1 - temp = x(j) - DO i=n,j+1,-1 - temp = temp - a(i, j)*x(i) - ENDDO - CALL PUSHINTEGER4(i + 1) - IF (nounit) THEN - CALL PUSHREAL4(temp) - temp = temp/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(x(j)) - x(j) = temp - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - DO j=1,n,1 - CALL POPREAL4(x(j)) - tempb = xb(j) - xb(j) = 0.0 - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(temp) - tempb0 = tempb/a(j, j) - tempb = tempb0 - ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) - END IF - CALL POPINTEGER4(ad_to1) - DO i=ad_to1,n,1 - ab(i, j) = ab(i, j) - x(i)*tempb - xb(i) = xb(i) - a(i, j)*tempb - ENDDO - xb(j) = xb(j) + tempb - ENDDO - ELSE - kx = kx + (n-1)*incx - jx = kx - DO j=n,1,-1 - temp = x(jx) - ix = kx - DO i=n,j+1,-1 - temp = temp - a(i, j)*x(ix) - CALL PUSHINTEGER4(ix) - ix = ix - incx - ENDDO - CALL PUSHINTEGER4(i + 1) - IF (nounit) THEN - CALL PUSHREAL4(temp) - temp = temp/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(x(jx)) - x(jx) = temp - CALL PUSHINTEGER4(jx) - jx = jx - incx - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - ab(ii2, ii1) = 0.0 - ENDDO - ENDDO - DO j=1,n,1 - CALL POPINTEGER4(jx) - CALL POPREAL4(x(jx)) - tempb = xb(jx) - xb(jx) = 0.0 - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(temp) - tempb0 = tempb/a(j, j) - tempb = tempb0 - ab(j, j) = ab(j, j) - temp*tempb0/a(j, j) - END IF - CALL POPINTEGER4(ad_to2) - DO i=ad_to2,n,1 - CALL POPINTEGER4(ix) - ab(i, j) = ab(i, j) - x(ix)*tempb - xb(ix) = xb(ix) - a(i, j)*tempb - ENDDO - xb(jx) = xb(jx) + tempb - ENDDO - END IF - CALL POPCONTROL1B(branch) - END IF - END IF - CALL POPCONTROL3B(branch) - END + END DO + END DO + +C Bb = Yb (no alpha in TRSV) + DO I = 1, N + XB(KX + (I-1)*INCX) = YB(I) + END DO + + RETURN + END SUBROUTINE STRSV_B diff --git a/BLAS/src/strsv_bv.f b/BLAS/src/strsv_bv.f index 89a5d36..e5e5b6d 100644 --- a/BLAS/src/strsv_bv.f +++ b/BLAS/src/strsv_bv.f @@ -152,595 +152,686 @@ C> \endverbatim C> C ===================================================================== - SUBROUTINE STRSV_BV(uplo, trans, diag, n, a, ab, lda, x, xb, incx - + , nbdirs) - IMPLICIT NONE - INCLUDE 'DIFFSIZES.inc' -C Hint: ISIZE2OFa should be the size of dimension 2 of array a -C Hint: nbdirsmax should be the maximum number of differentiation directions -C -C -- Reference BLAS level2 routine -- -C -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -C -C .. Scalar Arguments .. - INTEGER incx, lda, n - CHARACTER diag, trans, uplo -C .. -C .. Array Arguments .. - REAL a(lda, *), x(*) - REAL ab(nbdirsmax, lda, *), xb(nbdirsmax, *) -C .. -C -C ===================================================================== -C .. -C .. Local Scalars .. - REAL temp - REAL tempb(nbdirsmax) - INTEGER i, info, ix, j, jx, kx - LOGICAL nounit - EXTERNAL LSAME - INTEGER ISIZE2OFA -C .. -C .. External Functions .. - INTEGER get_ISIZE2OFA - EXTERNAL get_ISIZE2OFA - LOGICAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, check_ISIZE2OFA_initialized -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX - INTEGER max1 - INTEGER nd - REAL tempb0(nbdirsmax) - INTEGER ad_from - INTEGER*4 branch - INTEGER ad_from0 - INTEGER ad_from1 - INTEGER ad_from2 - INTEGER ad_to - INTEGER ad_to0 - INTEGER ad_to1 - INTEGER ad_to2 - INTEGER ii2 - INTEGER ii1 - INTEGER nbdirs -C .. +C SUBROUTINE STRSV_BV(uplo, trans, diag, n, a, ab, lda, x, xb, incx +C + , nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: ISIZE2OFa should be the size of dimension 2 of array a +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C REAL a(lda, *), x(*) +C REAL ab(nbdirsmax, lda, *), xb(nbdirsmax, *) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C REAL temp +C REAL tempb(nbdirsmax) +C INTEGER i, info, ix, j, jx, kx +C LOGICAL nounit +C EXTERNAL LSAME +C INTEGER ISIZE2OFA +CC .. +CC .. External Functions .. +C INTEGER get_ISIZE2OFA +C EXTERNAL get_ISIZE2OFA +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA, check_ISIZE2OFA_initialized +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +C INTEGER max1 +C INTEGER nd +C REAL tempb0(nbdirsmax) +C INTEGER ad_from +C INTEGER*4 branch +C INTEGER ad_from0 +C INTEGER ad_from1 +C INTEGER ad_from2 +C INTEGER ad_to +C INTEGER ad_to0 +C INTEGER ad_to1 +C INTEGER ad_to2 +C INTEGER ii2 +C INTEGER ii1 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C CALL check_ISIZE2OFA_initialized() +C ISIZE2OFA = get_ISIZE2OFA() +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C CALL PUSHCONTROL3B(0) +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C CALL PUSHCONTROL3B(1) +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C CALL PUSHCONTROL3B(2) +C info = 3 +C ELSE IF (n .LT. 0) THEN +C CALL PUSHCONTROL3B(3) +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C CALL PUSHCONTROL3B(4) +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C CALL PUSHCONTROL3B(5) +C info = 8 +C ELSE +C CALL PUSHCONTROL3B(5) +C END IF +C END IF +C IF (info .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C IF (n .EQ. 0) THEN +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C ELSE +CC +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C CALL PUSHCONTROL1B(0) +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C CALL PUSHCONTROL1B(1) +C kx = 1 +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL4(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(temp) +C temp = x(j) +C ad_from = j - 1 +C DO i=ad_from,1,-1 +C CALL PUSHREAL4(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C DO nd=1,nbdirsmax +C tempb(nd) = 0.0 +C ENDDO +C CALL POPINTEGER4(ad_from) +C DO i=1,ad_from,1 +C CALL POPREAL4(x(i)) +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) - a(i, j)*xb(nd, i) +C ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, i) +C ENDDO +C ENDDO +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(x(j)) +C DO nd=1,nbdirs +C tempb0(nd) = xb(nd, j)/a(j, j) +C xb(nd, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - x(j)*tempb0(nd)/a(j +C + , j) +C ENDDO +C END IF +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C CALL PUSHREAL4(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from0 = j - 1 +C DO i=ad_from0,1,-1 +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C CALL PUSHREAL4(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from0) +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C DO nd=1,nbdirsmax +C tempb(nd) = 0.0 +C ENDDO +C CALL POPINTEGER4(ad_from0) +C DO i=1,ad_from0,1 +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) - a(i, j)*xb(nd, ix) +C ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, ix) +C ENDDO +C CALL POPREAL4(x(ix)) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(x(jx)) +C DO nd=1,nbdirs +C tempb0(nd) = xb(nd, jx)/a(j, j) +C xb(nd, jx) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - x(jx)*tempb0(nd)/a(j +C + , j) +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHREAL4(x(j)) +C x(j) = x(j)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(temp) +C temp = x(j) +C ad_from1 = j + 1 +C DO i=ad_from1,n +C CALL PUSHREAL4(x(i)) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from1) +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C DO nd=1,nbdirsmax +C tempb(nd) = 0.0 +C ENDDO +C CALL POPINTEGER4(ad_from1) +C DO i=n,ad_from1,-1 +C CALL POPREAL4(x(i)) +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) - a(i, j)*xb(nd, i) +C ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, i) +C ENDDO +C ENDDO +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(x(j)) +C DO nd=1,nbdirs +C tempb0(nd) = xb(nd, j)/a(j, j) +C xb(nd, j) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - x(j)*tempb0(nd)/a(j, j +C + ) +C ENDDO +C END IF +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C CALL PUSHREAL4(x(jx)) +C x(jx) = x(jx)/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(temp) +C temp = x(jx) +C CALL PUSHINTEGER4(ix) +C ix = jx +C ad_from2 = j + 1 +C DO i=ad_from2,n +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C CALL PUSHREAL4(x(ix)) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C CALL PUSHINTEGER4(ad_from2) +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C DO nd=1,nbdirsmax +C tempb(nd) = 0.0 +C ENDDO +C CALL POPINTEGER4(ad_from2) +C DO i=n,ad_from2,-1 +C DO nd=1,nbdirs +C tempb(nd) = tempb(nd) - a(i, j)*xb(nd, ix) +C ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, ix) +C ENDDO +C CALL POPREAL4(x(ix)) +C CALL POPINTEGER4(ix) +C ENDDO +C CALL POPINTEGER4(ix) +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(x(jx)) +C DO nd=1,nbdirs +C tempb0(nd) = xb(nd, jx)/a(j, j) +C xb(nd, jx) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - x(jx)*tempb0(nd)/a(j, +C + j) +C ENDDO +C END IF +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C temp = x(j) +C DO i=1,j-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPREAL4(x(j)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, j) +C xb(nd, j) = 0.0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j +C + ) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to) +C DO i=ad_to,1,-1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) - x(i)*tempb(nd) +C xb(nd, i) = xb(nd, i) - a(i, j)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C temp = x(jx) +C ix = kx +C DO i=1,j-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix + incx +C ENDDO +C CALL PUSHINTEGER4(i - 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx + incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=n,1,-1 +C CALL POPINTEGER4(jx) +C CALL POPREAL4(x(jx)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, jx) +C xb(nd, jx) = 0.0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j +C + ) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to0) +C DO i=ad_to0,1,-1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) - x(ix)*tempb(nd) +C xb(nd, ix) = xb(nd, ix) - a(i, j)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C temp = x(j) +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(i) +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(x(j)) +C x(j) = temp +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPREAL4(x(j)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, j) +C xb(nd, j) = 0.0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to1) +C DO i=ad_to1,n,1 +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) - x(i)*tempb(nd) +C xb(nd, i) = xb(nd, i) - a(i, j)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C xb(nd, j) = xb(nd, j) + tempb(nd) +C ENDDO +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C temp = x(jx) +C ix = kx +C DO i=n,j+1,-1 +C temp = temp - a(i, j)*x(ix) +C CALL PUSHINTEGER4(ix) +C ix = ix - incx +C ENDDO +C CALL PUSHINTEGER4(i + 1) +C IF (nounit) THEN +C CALL PUSHREAL4(temp) +C temp = temp/a(j, j) +C CALL PUSHCONTROL1B(0) +C ELSE +C CALL PUSHCONTROL1B(1) +C END IF +C CALL PUSHREAL4(x(jx)) +C x(jx) = temp +C CALL PUSHINTEGER4(jx) +C jx = jx - incx +C ENDDO +C DO ii1=1,ISIZE2OFa +C DO ii2=1,lda +C DO nd=1,nbdirsmax +C ab(nd, ii2, ii1) = 0.0 +C ENDDO +C ENDDO +C ENDDO +C DO j=1,n,1 +C CALL POPINTEGER4(jx) +C CALL POPREAL4(x(jx)) +C DO nd=1,nbdirs +C tempb(nd) = xb(nd, jx) +C xb(nd, jx) = 0.0 +C ENDDO +C CALL POPCONTROL1B(branch) +C IF (branch .EQ. 0) THEN +C CALL POPREAL4(temp) +C DO nd=1,nbdirs +C tempb(nd) = tempb0(nd) +C ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j) +C ENDDO +C END IF +C CALL POPINTEGER4(ad_to2) +C DO i=ad_to2,n,1 +C CALL POPINTEGER4(ix) +C DO nd=1,nbdirs +C ab(nd, i, j) = ab(nd, i, j) - x(ix)*tempb(nd) +C xb(nd, ix) = xb(nd, ix) - a(i, j)*tempb(nd) +C ENDDO +C ENDDO +C DO nd=1,nbdirs +C xb(nd, jx) = xb(nd, jx) + tempb(nd) +C ENDDO +C ENDDO +C END IF +C CALL POPCONTROL1B(branch) +C END IF +C END IF +C CALL POPCONTROL3B(branch) +C END + + SUBROUTINE STRSV_BV(UPLO, TRANS, DIAG, N, A, AB, LDA, X, XB, + + INCX, NBDIRS) C -C Test the input parameters. +C Vector reverse-mode (adjoint) derivative of STRSV, black-box/Giles-style. +C Self-contained -- does not call STRSV_B. C -C Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) - CALL check_ISIZE2OFA_initialized() - ISIZE2OFA = get_ISIZE2OFA() - IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN - WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, - + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' - STOP 1 + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX, NBDIRS + REAL A(LDA,*), AB(NBDIRSMAX,LDA,*) + REAL X(*), XB(NBDIRSMAX,*) + + REAL BLOC(N), S(N), YB(N), AB_SLICE(LDA,LDA) + CHARACTER TRANS_T + LOGICAL UPPER, UNIT, NOTRANS + INTEGER ND, I, J, KX + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 END IF -C - info = 0 - IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN - CALL PUSHCONTROL3B(0) - info = 1 - ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) - + .AND. (.NOT.LSAME(trans, 'C'))) THEN - CALL PUSHCONTROL3B(1) - info = 2 - ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN - CALL PUSHCONTROL3B(2) - info = 3 - ELSE IF (n .LT. 0) THEN - CALL PUSHCONTROL3B(3) - info = 4 + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 ELSE - IF (1 .LT. n) THEN - max1 = n - ELSE - max1 = 1 - END IF - IF (lda .LT. max1) THEN - CALL PUSHCONTROL3B(4) - info = 6 - ELSE IF (incx .EQ. 0) THEN - CALL PUSHCONTROL3B(5) - info = 8 - ELSE - CALL PUSHCONTROL3B(5) - END IF + KX = 1 - (N-1)*INCX END IF - IF (info .EQ. 0) THEN -C -C Quick return if possible. -C - IF (n .EQ. 0) THEN - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - ELSE -C - nounit = LSAME(diag, 'N') -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF (incx .LE. 0) THEN - CALL PUSHCONTROL1B(0) - kx = 1 - (n-1)*incx - ELSE IF (incx .NE. 1) THEN - CALL PUSHCONTROL1B(1) - kx = 1 - ELSE - CALL PUSHCONTROL1B(1) - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF (LSAME(trans, 'N')) THEN -C -C Form x := inv( A )*x. -C - IF (LSAME(uplo, 'U')) THEN - IF (incx .EQ. 1) THEN - DO j=n,1,-1 - IF (nounit) THEN - CALL PUSHREAL4(x(j)) - x(j) = x(j)/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(temp) - temp = x(j) - ad_from = j - 1 - DO i=ad_from,1,-1 - CALL PUSHREAL4(x(i)) - x(i) = x(i) - temp*a(i, j) - ENDDO - CALL PUSHINTEGER4(ad_from) - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - DO j=1,n,1 - DO nd=1,nbdirsmax - tempb(nd) = 0.0 - ENDDO - CALL POPINTEGER4(ad_from) - DO i=1,ad_from,1 - CALL POPREAL4(x(i)) - DO nd=1,nbdirs - tempb(nd) = tempb(nd) - a(i, j)*xb(nd, i) - ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, i) - ENDDO - ENDDO - CALL POPREAL4(temp) - DO nd=1,nbdirs - xb(nd, j) = xb(nd, j) + tempb(nd) - ENDDO - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(x(j)) - DO nd=1,nbdirs - tempb0(nd) = xb(nd, j)/a(j, j) - xb(nd, j) = tempb0(nd) - ab(nd, j, j) = ab(nd, j, j) - x(j)*tempb0(nd)/a(j - + , j) - ENDDO - END IF - ENDDO - ELSE - jx = kx + (n-1)*incx - DO j=n,1,-1 - IF (nounit) THEN - CALL PUSHREAL4(x(jx)) - x(jx) = x(jx)/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(temp) - temp = x(jx) - CALL PUSHINTEGER4(ix) - ix = jx - ad_from0 = j - 1 - DO i=ad_from0,1,-1 - CALL PUSHINTEGER4(ix) - ix = ix - incx - CALL PUSHREAL4(x(ix)) - x(ix) = x(ix) - temp*a(i, j) - ENDDO - CALL PUSHINTEGER4(ad_from0) - CALL PUSHINTEGER4(jx) - jx = jx - incx - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - DO j=1,n,1 - CALL POPINTEGER4(jx) - DO nd=1,nbdirsmax - tempb(nd) = 0.0 - ENDDO - CALL POPINTEGER4(ad_from0) - DO i=1,ad_from0,1 - DO nd=1,nbdirs - tempb(nd) = tempb(nd) - a(i, j)*xb(nd, ix) - ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, ix) - ENDDO - CALL POPREAL4(x(ix)) - CALL POPINTEGER4(ix) - ENDDO - CALL POPINTEGER4(ix) - CALL POPREAL4(temp) - DO nd=1,nbdirs - xb(nd, jx) = xb(nd, jx) + tempb(nd) - ENDDO - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(x(jx)) - DO nd=1,nbdirs - tempb0(nd) = xb(nd, jx)/a(j, j) - xb(nd, jx) = tempb0(nd) - ab(nd, j, j) = ab(nd, j, j) - x(jx)*tempb0(nd)/a(j - + , j) - ENDDO - END IF - ENDDO - END IF - ELSE IF (incx .EQ. 1) THEN - DO j=1,n - IF (nounit) THEN - CALL PUSHREAL4(x(j)) - x(j) = x(j)/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(temp) - temp = x(j) - ad_from1 = j + 1 - DO i=ad_from1,n - CALL PUSHREAL4(x(i)) - x(i) = x(i) - temp*a(i, j) - ENDDO - CALL PUSHINTEGER4(ad_from1) - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - DO j=n,1,-1 - DO nd=1,nbdirsmax - tempb(nd) = 0.0 - ENDDO - CALL POPINTEGER4(ad_from1) - DO i=n,ad_from1,-1 - CALL POPREAL4(x(i)) - DO nd=1,nbdirs - tempb(nd) = tempb(nd) - a(i, j)*xb(nd, i) - ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, i) - ENDDO - ENDDO - CALL POPREAL4(temp) - DO nd=1,nbdirs - xb(nd, j) = xb(nd, j) + tempb(nd) - ENDDO - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(x(j)) - DO nd=1,nbdirs - tempb0(nd) = xb(nd, j)/a(j, j) - xb(nd, j) = tempb0(nd) - ab(nd, j, j) = ab(nd, j, j) - x(j)*tempb0(nd)/a(j, j - + ) - ENDDO - END IF - ENDDO - ELSE - jx = kx - DO j=1,n - IF (nounit) THEN - CALL PUSHREAL4(x(jx)) - x(jx) = x(jx)/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(temp) - temp = x(jx) - CALL PUSHINTEGER4(ix) - ix = jx - ad_from2 = j + 1 - DO i=ad_from2,n - CALL PUSHINTEGER4(ix) - ix = ix + incx - CALL PUSHREAL4(x(ix)) - x(ix) = x(ix) - temp*a(i, j) - ENDDO - CALL PUSHINTEGER4(ad_from2) - CALL PUSHINTEGER4(jx) - jx = jx + incx - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - DO j=n,1,-1 - CALL POPINTEGER4(jx) - DO nd=1,nbdirsmax - tempb(nd) = 0.0 - ENDDO - CALL POPINTEGER4(ad_from2) - DO i=n,ad_from2,-1 - DO nd=1,nbdirs - tempb(nd) = tempb(nd) - a(i, j)*xb(nd, ix) - ab(nd, i, j) = ab(nd, i, j) - temp*xb(nd, ix) - ENDDO - CALL POPREAL4(x(ix)) - CALL POPINTEGER4(ix) - ENDDO - CALL POPINTEGER4(ix) - CALL POPREAL4(temp) - DO nd=1,nbdirs - xb(nd, jx) = xb(nd, jx) + tempb(nd) - ENDDO - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(x(jx)) - DO nd=1,nbdirs - tempb0(nd) = xb(nd, jx)/a(j, j) - xb(nd, jx) = tempb0(nd) - ab(nd, j, j) = ab(nd, j, j) - x(jx)*tempb0(nd)/a(j, - + j) - ENDDO - END IF - ENDDO - END IF - ELSE IF (LSAME(uplo, 'U')) THEN -C -C Form x := inv( A**T )*x. -C - IF (incx .EQ. 1) THEN - DO j=1,n - temp = x(j) - DO i=1,j-1 - temp = temp - a(i, j)*x(i) - ENDDO - CALL PUSHINTEGER4(i - 1) - IF (nounit) THEN - CALL PUSHREAL4(temp) - temp = temp/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(x(j)) - x(j) = temp - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - DO j=n,1,-1 - CALL POPREAL4(x(j)) - DO nd=1,nbdirs - tempb(nd) = xb(nd, j) - xb(nd, j) = 0.0 - ENDDO - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(temp) - DO nd=1,nbdirs - tempb(nd) = tempb0(nd) - ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j - + ) - ENDDO - END IF - CALL POPINTEGER4(ad_to) - DO i=ad_to,1,-1 - DO nd=1,nbdirs - ab(nd, i, j) = ab(nd, i, j) - x(i)*tempb(nd) - xb(nd, i) = xb(nd, i) - a(i, j)*tempb(nd) - ENDDO - ENDDO - DO nd=1,nbdirs - xb(nd, j) = xb(nd, j) + tempb(nd) - ENDDO - ENDDO - ELSE - jx = kx - DO j=1,n - temp = x(jx) - ix = kx - DO i=1,j-1 - temp = temp - a(i, j)*x(ix) - CALL PUSHINTEGER4(ix) - ix = ix + incx - ENDDO - CALL PUSHINTEGER4(i - 1) - IF (nounit) THEN - CALL PUSHREAL4(temp) - temp = temp/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(x(jx)) - x(jx) = temp - CALL PUSHINTEGER4(jx) - jx = jx + incx - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - DO j=n,1,-1 - CALL POPINTEGER4(jx) - CALL POPREAL4(x(jx)) - DO nd=1,nbdirs - tempb(nd) = xb(nd, jx) - xb(nd, jx) = 0.0 - ENDDO - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(temp) - DO nd=1,nbdirs - tempb(nd) = tempb0(nd) - ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j - + ) - ENDDO - END IF - CALL POPINTEGER4(ad_to0) - DO i=ad_to0,1,-1 - CALL POPINTEGER4(ix) - DO nd=1,nbdirs - ab(nd, i, j) = ab(nd, i, j) - x(ix)*tempb(nd) - xb(nd, ix) = xb(nd, ix) - a(i, j)*tempb(nd) - ENDDO - ENDDO - DO nd=1,nbdirs - xb(nd, jx) = xb(nd, jx) + tempb(nd) - ENDDO - ENDDO - END IF - ELSE IF (incx .EQ. 1) THEN - DO j=n,1,-1 - temp = x(j) - DO i=n,j+1,-1 - temp = temp - a(i, j)*x(i) - ENDDO - CALL PUSHINTEGER4(i + 1) - IF (nounit) THEN - CALL PUSHREAL4(temp) - temp = temp/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(x(j)) - x(j) = temp - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - DO j=1,n,1 - CALL POPREAL4(x(j)) - DO nd=1,nbdirs - tempb(nd) = xb(nd, j) - xb(nd, j) = 0.0 - ENDDO - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(temp) - DO nd=1,nbdirs - tempb(nd) = tempb0(nd) - ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j) - ENDDO - END IF - CALL POPINTEGER4(ad_to1) - DO i=ad_to1,n,1 - DO nd=1,nbdirs - ab(nd, i, j) = ab(nd, i, j) - x(i)*tempb(nd) - xb(nd, i) = xb(nd, i) - a(i, j)*tempb(nd) - ENDDO - ENDDO - DO nd=1,nbdirs - xb(nd, j) = xb(nd, j) + tempb(nd) - ENDDO - ENDDO - ELSE - kx = kx + (n-1)*incx - jx = kx - DO j=n,1,-1 - temp = x(jx) - ix = kx - DO i=n,j+1,-1 - temp = temp - a(i, j)*x(ix) - CALL PUSHINTEGER4(ix) - ix = ix - incx - ENDDO - CALL PUSHINTEGER4(i + 1) - IF (nounit) THEN - CALL PUSHREAL4(temp) - temp = temp/a(j, j) - CALL PUSHCONTROL1B(0) - ELSE - CALL PUSHCONTROL1B(1) - END IF - CALL PUSHREAL4(x(jx)) - x(jx) = temp - CALL PUSHINTEGER4(jx) - jx = jx - incx - ENDDO - DO ii1=1,ISIZE2OFa - DO ii2=1,lda - DO nd=1,nbdirsmax - ab(nd, ii2, ii1) = 0.0 - ENDDO - ENDDO - ENDDO - DO j=1,n,1 - CALL POPINTEGER4(jx) - CALL POPREAL4(x(jx)) - DO nd=1,nbdirs - tempb(nd) = xb(nd, jx) - xb(nd, jx) = 0.0 - ENDDO - CALL POPCONTROL1B(branch) - IF (branch .EQ. 0) THEN - CALL POPREAL4(temp) - DO nd=1,nbdirs - tempb(nd) = tempb0(nd) - ab(nd, j, j) = ab(nd, j, j) - temp*tempb0(nd)/a(j, j) - ENDDO - END IF - CALL POPINTEGER4(ad_to2) - DO i=ad_to2,n,1 - CALL POPINTEGER4(ix) - DO nd=1,nbdirs - ab(nd, i, j) = ab(nd, i, j) - x(ix)*tempb(nd) - xb(nd, ix) = xb(nd, ix) - a(i, j)*tempb(nd) - ENDDO - ENDDO - DO nd=1,nbdirs - xb(nd, jx) = xb(nd, jx) + tempb(nd) - ENDDO - ENDDO - END IF - CALL POPCONTROL1B(branch) - END IF + + UPPER = (UPLO.EQ.'U' .OR. UPLO.EQ.'u') + UNIT = (DIAG.EQ.'U' .OR. DIAG.EQ.'u') + NOTRANS = (TRANS.EQ.'N' .OR. TRANS.EQ.'n') + IF (NOTRANS) THEN + TRANS_T = 'T' + ELSE + TRANS_T = 'N' END IF - CALL POPCONTROL3B(branch) - END + +C Gather original B once, recompute S once (shared across directions) + DO I = 1, N + BLOC(I) = X(KX + (I-1)*INCX) + END DO + DO I = 1, N + S(I) = BLOC(I) + END DO + CALL STRSV(UPLO, TRANS, DIAG, N, A, LDA, S, 1) + + DO ND = 1, NBDIRS + + DO I = 1, N + YB(I) = XB(ND, KX + (I-1)*INCX) + END DO + + CALL STRSV(UPLO, TRANS_T, DIAG, N, A, LDA, YB, 1) + + DO J = 1, LDA + DO I = 1, LDA + AB_SLICE(I,J) = 0.0E0 + END DO + END DO + DO J = 1, N + DO I = 1, N + IF ((UPPER.AND.I.LE.J).OR.(.NOT.UPPER.AND.I.GE.J)) THEN + IF (.NOT.(UNIT.AND.I.EQ.J)) THEN + IF (NOTRANS) THEN + AB_SLICE(I,J) = -YB(I)*S(J) + ELSE + AB_SLICE(I,J) = -S(I)*YB(J) + END IF + END IF + END IF + END DO + END DO + + DO I = 1, N + XB(ND, KX + (I-1)*INCX) = YB(I) + END DO + DO J = 1, LDA + DO I = 1, LDA + AB(ND,I,J) = AB_SLICE(I,J) + END DO + END DO + + END DO + + RETURN + END SUBROUTINE STRSV_BV diff --git a/BLAS/src/strsv_d.f b/BLAS/src/strsv_d.f index b7a8f9b..10de6fe 100644 --- a/BLAS/src/strsv_d.f +++ b/BLAS/src/strsv_d.f @@ -152,246 +152,303 @@ C> \endverbatim C> C ===================================================================== - SUBROUTINE STRSV_D(uplo, trans, diag, n, a, ad, lda, x, xd, incx) - IMPLICIT NONE -C -C -- Reference BLAS level2 routine -- -C -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -C -C .. Scalar Arguments .. - INTEGER incx, lda, n - CHARACTER diag, trans, uplo -C .. -C .. Array Arguments .. - REAL a(lda, *), x(*) - REAL ad(lda, *), xd(*) -C .. -C -C ===================================================================== -C .. -C .. Local Scalars .. - REAL temp - REAL tempd - INTEGER i, info, ix, j, jx, kx - LOGICAL nounit - EXTERNAL LSAME -C .. -C .. External Functions .. - LOGICAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX - INTEGER max1 - REAL temp0 -C .. -C -C Test the input parameters. +C SUBROUTINE STRSV_D(uplo, trans, diag, n, a, ad, lda, x, xd, incx) +C IMPLICIT NONE +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C REAL a(lda, *), x(*) +C REAL ad(lda, *), xd(*) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C REAL temp +C REAL tempd +C INTEGER i, info, ix, j, jx, kx +C LOGICAL nounit +C EXTERNAL LSAME +CC .. +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +C INTEGER max1 +C REAL temp0 +CC .. +CC +CC Test the input parameters. +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 3 +C ELSE IF (n .LT. 0) THEN +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C info = 8 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('STRSV ', info) +C RETURN +C ELSE IF (n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE +CC +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C kx = 1 +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) +C x(j) = temp0 +C END IF +C tempd = xd(j) +C temp = x(j) +C DO i=j-1,1,-1 +C xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) +C x(jx) = temp0 +C END IF +C tempd = xd(jx) +C temp = x(jx) +C ix = jx +C DO i=j-1,1,-1 +C ix = ix - incx +C xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx - incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) +C x(j) = temp0 +C END IF +C tempd = xd(j) +C temp = x(j) +C DO i=j+1,n +C xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) +C x(jx) = temp0 +C END IF +C tempd = xd(jx) +C temp = x(jx) +C ix = jx +C DO i=j+1,n +C ix = ix + incx +C xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C tempd = xd(j) +C temp = x(j) +C DO i=1,j-1 +C tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C xd(j) = tempd +C x(j) = temp +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C tempd = xd(jx) +C temp = x(jx) +C ix = kx +C DO i=1,j-1 +C tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) +C temp = temp - a(i, j)*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C xd(jx) = tempd +C x(jx) = temp +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C tempd = xd(j) +C temp = x(j) +C DO i=n,j+1,-1 +C tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C xd(j) = tempd +C x(j) = temp +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C tempd = xd(jx) +C temp = x(jx) +C ix = kx +C DO i=n,j+1,-1 +C tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) +C temp = temp - a(i, j)*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C tempd = (tempd-temp0*ad(j, j))/a(j, j) +C temp = temp0 +C END IF +C xd(jx) = tempd +C x(jx) = temp +C jx = jx - incx +C ENDDO +C END IF +CC +C RETURN +CC +CC End of STRSV +CC +C END IF +C END + + SUBROUTINE STRSV_D(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, INCX) C - info = 0 - IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN - info = 1 - ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) - + .AND. (.NOT.LSAME(trans, 'C'))) THEN - info = 2 - ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN - info = 3 - ELSE IF (n .LT. 0) THEN - info = 4 - ELSE - IF (1 .LT. n) THEN - max1 = n - ELSE - max1 = 1 - END IF - IF (lda .LT. max1) THEN - info = 6 - ELSE IF (incx .EQ. 0) THEN - info = 8 - END IF - END IF - IF (info .NE. 0) THEN - CALL XERBLA('STRSV ', info) - RETURN - ELSE IF (n .EQ. 0) THEN +C Forward-mode derivative of STRSV via the black-box / Giles-style +C approach: differentiate op(A)*s = b directly (the exact vector case +C from the Giles appendix). Uses only the original STRSV and STRMV. C -C Quick return if possible. +C CONVENTION (matches the primal STRSV's own in-place behavior): +C X, XD : overwritten in place with the solution S and its +C derivative dS, exactly like the primal/forward routine. C - RETURN + IMPLICIT NONE + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX + REAL A(LDA,*), AD(LDA,*) + REAL X(*), XD(*) + + REAL S(N), W(N) + INTEGER I, KX + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 ELSE -C - nounit = LSAME(diag, 'N') -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF (incx .LE. 0) THEN - kx = 1 - (n-1)*incx - ELSE IF (incx .NE. 1) THEN - kx = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF (LSAME(trans, 'N')) THEN -C -C Form x := inv( A )*x. -C - IF (LSAME(uplo, 'U')) THEN - IF (incx .EQ. 1) THEN - DO j=n,1,-1 - IF (nounit) THEN - temp0 = x(j)/a(j, j) - xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) - x(j) = temp0 - END IF - tempd = xd(j) - temp = x(j) - DO i=j-1,1,-1 - xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) - x(i) = x(i) - temp*a(i, j) - ENDDO - ENDDO - ELSE - jx = kx + (n-1)*incx - DO j=n,1,-1 - IF (nounit) THEN - temp0 = x(jx)/a(j, j) - xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) - x(jx) = temp0 - END IF - tempd = xd(jx) - temp = x(jx) - ix = jx - DO i=j-1,1,-1 - ix = ix - incx - xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) - x(ix) = x(ix) - temp*a(i, j) - ENDDO - jx = jx - incx - ENDDO - END IF - ELSE IF (incx .EQ. 1) THEN - DO j=1,n - IF (nounit) THEN - temp0 = x(j)/a(j, j) - xd(j) = (xd(j)-temp0*ad(j, j))/a(j, j) - x(j) = temp0 - END IF - tempd = xd(j) - temp = x(j) - DO i=j+1,n - xd(i) = xd(i) - a(i, j)*tempd - temp*ad(i, j) - x(i) = x(i) - temp*a(i, j) - ENDDO - ENDDO - ELSE - jx = kx - DO j=1,n - IF (nounit) THEN - temp0 = x(jx)/a(j, j) - xd(jx) = (xd(jx)-temp0*ad(j, j))/a(j, j) - x(jx) = temp0 - END IF - tempd = xd(jx) - temp = x(jx) - ix = jx - DO i=j+1,n - ix = ix + incx - xd(ix) = xd(ix) - a(i, j)*tempd - temp*ad(i, j) - x(ix) = x(ix) - temp*a(i, j) - ENDDO - jx = jx + incx - ENDDO - END IF - ELSE IF (LSAME(uplo, 'U')) THEN -C -C Form x := inv( A**T )*x. -C - IF (incx .EQ. 1) THEN - DO j=1,n - tempd = xd(j) - temp = x(j) - DO i=1,j-1 - tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) - temp = temp - a(i, j)*x(i) - ENDDO - IF (nounit) THEN - temp0 = temp/a(j, j) - tempd = (tempd-temp0*ad(j, j))/a(j, j) - temp = temp0 - END IF - xd(j) = tempd - x(j) = temp - ENDDO - ELSE - jx = kx - DO j=1,n - tempd = xd(jx) - temp = x(jx) - ix = kx - DO i=1,j-1 - tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) - temp = temp - a(i, j)*x(ix) - ix = ix + incx - ENDDO - IF (nounit) THEN - temp0 = temp/a(j, j) - tempd = (tempd-temp0*ad(j, j))/a(j, j) - temp = temp0 - END IF - xd(jx) = tempd - x(jx) = temp - jx = jx + incx - ENDDO - END IF - ELSE IF (incx .EQ. 1) THEN - DO j=n,1,-1 - tempd = xd(j) - temp = x(j) - DO i=n,j+1,-1 - tempd = tempd - x(i)*ad(i, j) - a(i, j)*xd(i) - temp = temp - a(i, j)*x(i) - ENDDO - IF (nounit) THEN - temp0 = temp/a(j, j) - tempd = (tempd-temp0*ad(j, j))/a(j, j) - temp = temp0 - END IF - xd(j) = tempd - x(j) = temp - ENDDO - ELSE - kx = kx + (n-1)*incx - jx = kx - DO j=n,1,-1 - tempd = xd(jx) - temp = x(jx) - ix = kx - DO i=n,j+1,-1 - tempd = tempd - x(ix)*ad(i, j) - a(i, j)*xd(ix) - temp = temp - a(i, j)*x(ix) - ix = ix - incx - ENDDO - IF (nounit) THEN - temp0 = temp/a(j, j) - tempd = (tempd-temp0*ad(j, j))/a(j, j) - temp = temp0 - END IF - xd(jx) = tempd - x(jx) = temp - jx = jx - incx - ENDDO - END IF -C - RETURN -C -C End of STRSV -C + KX = 1 - (N-1)*INCX END IF - END + +C Step 1: solve for S, overwriting X in place (matches primal convention) + CALL STRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + +C Gather S (now held in X) into a contiguous local copy + DO I = 1, N + S(I) = X(KX + (I-1)*INCX) + END DO + +C Step 2: T = op(AD)*S (local work vector, unit stride) + DO I = 1, N + W(I) = S(I) + END DO + CALL STRMV(UPLO, TRANS, DIAG, N, AD, LDA, W, 1) + +C Step 3: RHS = XD_in - T, gathered from XD into W (reused) + DO I = 1, N + W(I) = XD(KX + (I-1)*INCX) - W(I) + END DO + +C Step 4: solve op(A)*dS = RHS -> W holds dS + CALL STRSV(UPLO, TRANS, DIAG, N, A, LDA, W, 1) + +C Scatter dS back into XD + DO I = 1, N + XD(KX + (I-1)*INCX) = W(I) + END DO + + RETURN + END SUBROUTINE STRSV_D diff --git a/BLAS/src/strsv_dv.f b/BLAS/src/strsv_dv.f index 8fa7dd4..ad9d784 100644 --- a/BLAS/src/strsv_dv.f +++ b/BLAS/src/strsv_dv.f @@ -152,322 +152,388 @@ C> \endverbatim C> C ===================================================================== - SUBROUTINE STRSV_DV(uplo, trans, diag, n, a, ad, lda, x, xd, incx - + , nbdirs) - IMPLICIT NONE - INCLUDE 'DIFFSIZES.inc' -C Hint: nbdirsmax should be the maximum number of differentiation directions -C -C -- Reference BLAS level2 routine -- -C -- Reference BLAS is a software package provided by Univ. of Tennessee, -- -C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -C -C .. Scalar Arguments .. - INTEGER incx, lda, n - CHARACTER diag, trans, uplo -C .. -C .. Array Arguments .. - REAL a(lda, *), x(*) - REAL ad(nbdirsmax, lda, *), xd(nbdirsmax, *) -C .. -C -C ===================================================================== -C .. -C .. Local Scalars .. - REAL temp - REAL tempd(nbdirsmax) - INTEGER i, info, ix, j, jx, kx - LOGICAL nounit - EXTERNAL LSAME -C .. -C .. External Functions .. - LOGICAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX - INTEGER max1 - INTEGER nd - REAL temp0 - INTEGER nbdirs -C .. +C SUBROUTINE STRSV_DV(uplo, trans, diag, n, a, ad, lda, x, xd, incx +C + , nbdirs) +C IMPLICIT NONE +C INCLUDE 'DIFFSIZES.inc' +CC Hint: nbdirsmax should be the maximum number of differentiation directions +CC +CC -- Reference BLAS level2 routine -- +CC -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +CC -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +CC +CC .. Scalar Arguments .. +C INTEGER incx, lda, n +C CHARACTER diag, trans, uplo +CC .. +CC .. Array Arguments .. +C REAL a(lda, *), x(*) +C REAL ad(nbdirsmax, lda, *), xd(nbdirsmax, *) +CC .. +CC +CC ===================================================================== +CC .. +CC .. Local Scalars .. +C REAL temp +C REAL tempd(nbdirsmax) +C INTEGER i, info, ix, j, jx, kx +C LOGICAL nounit +C EXTERNAL LSAME +CC .. +CC .. External Functions .. +C LOGICAL LSAME +CC .. +CC .. External Subroutines .. +C EXTERNAL XERBLA +CC .. +CC .. Intrinsic Functions .. +C INTRINSIC MAX +C INTEGER max1 +C INTEGER nd +C REAL temp0 +C INTEGER nbdirs +CC .. +CC +CC Test the input parameters. +CC +CC Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) +C IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN +C WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, +C + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' +C STOP 1 +C END IF +CC +C info = 0 +C IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN +C info = 1 +C ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) +C + .AND. (.NOT.LSAME(trans, 'C'))) THEN +C info = 2 +C ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN +C info = 3 +C ELSE IF (n .LT. 0) THEN +C info = 4 +C ELSE +C IF (1 .LT. n) THEN +C max1 = n +C ELSE +C max1 = 1 +C END IF +C IF (lda .LT. max1) THEN +C info = 6 +C ELSE IF (incx .EQ. 0) THEN +C info = 8 +C END IF +C END IF +C IF (info .NE. 0) THEN +C CALL XERBLA('STRSV ', info) +C RETURN +C ELSE IF (n .EQ. 0) THEN +CC +CC Quick return if possible. +CC +C RETURN +C ELSE +CC +C nounit = LSAME(diag, 'N') +CC +CC Set up the start point in X if the increment is not unity. This +CC will be ( N - 1 )*INCX too small for descending loops. +CC +C IF (incx .LE. 0) THEN +C kx = 1 - (n-1)*incx +C ELSE IF (incx .NE. 1) THEN +C kx = 1 +C END IF +CC +CC Start the operations. In this version the elements of A are +CC accessed sequentially with one pass through A. +CC +C IF (LSAME(trans, 'N')) THEN +CC +CC Form x := inv( A )*x. +CC +C IF (LSAME(uplo, 'U')) THEN +C IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(j) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=j-1,1,-1 +C DO nd=1,nbdirs +C xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad( +C + nd, i, j) +C ENDDO +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx + (n-1)*incx +C DO j=n,1,-1 +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(jx) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = jx +C DO i=j-1,1,-1 +C ix = ix - incx +C DO nd=1,nbdirs +C xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp* +C + ad(nd, i, j) +C ENDDO +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx - incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(j)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(j) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=j+1,n +C DO nd=1,nbdirs +C xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad(nd +C + , i, j) +C ENDDO +C x(i) = x(i) - temp*a(i, j) +C ENDDO +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C IF (nounit) THEN +C temp0 = x(jx)/a(j, j) +C DO nd=1,nbdirs +C xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C x(jx) = temp0 +C END IF +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = jx +C DO i=j+1,n +C ix = ix + incx +C DO nd=1,nbdirs +C xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp*ad( +C + nd, i, j) +C ENDDO +C x(ix) = x(ix) - temp*a(i, j) +C ENDDO +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (LSAME(uplo, 'U')) THEN +CC +CC Form x := inv( A**T )*x. +CC +C IF (incx .EQ. 1) THEN +C DO j=1,n +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=1,j-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd +C + (nd, i) +C ENDDO +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C xd(nd, j) = tempd(nd) +C ENDDO +C x(j) = temp +C ENDDO +C ELSE +C jx = kx +C DO j=1,n +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = kx +C DO i=1,j-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)* +C + xd(nd, ix) +C ENDDO +C temp = temp - a(i, j)*x(ix) +C ix = ix + incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C xd(nd, jx) = tempd(nd) +C ENDDO +C x(jx) = temp +C jx = jx + incx +C ENDDO +C END IF +C ELSE IF (incx .EQ. 1) THEN +C DO j=n,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, j) +C ENDDO +C temp = x(j) +C DO i=n,j+1,-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd( +C + nd, i) +C ENDDO +C temp = temp - a(i, j)*x(i) +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C xd(nd, j) = tempd(nd) +C ENDDO +C x(j) = temp +C ENDDO +C ELSE +C kx = kx + (n-1)*incx +C jx = kx +C DO j=n,1,-1 +C DO nd=1,nbdirs +C tempd(nd) = xd(nd, jx) +C ENDDO +C temp = x(jx) +C ix = kx +C DO i=n,j+1,-1 +C DO nd=1,nbdirs +C tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)*xd( +C + nd, ix) +C ENDDO +C temp = temp - a(i, j)*x(ix) +C ix = ix - incx +C ENDDO +C IF (nounit) THEN +C temp0 = temp/a(j, j) +C DO nd=1,nbdirs +C tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) +C ENDDO +C temp = temp0 +C END IF +C DO nd=1,nbdirs +C xd(nd, jx) = tempd(nd) +C ENDDO +C x(jx) = temp +C jx = jx - incx +C ENDDO +C END IF +CC +C RETURN +CC +CC End of STRSV +CC +C END IF +C END + + SUBROUTINE STRSV_DV(UPLO, TRANS, DIAG, N, A, AD, LDA, X, XD, + + INCX, NBDIRS) C -C Test the input parameters. +C Vector forward-mode derivative of STRSV, black-box/Giles-style. +C Self-contained -- does not call STRSV_D. C -C Check 0 < nbdirs <= nbdirsmax (required by DIFFSIZES.inc) - IF (nbdirs.LE.0 .OR. nbdirs.GT.nbdirsmax) THEN - WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', nbdirs, - + ' must be in 1..nbdirsmax=', nbdirsmax, '. Stopping.' - STOP 1 + IMPLICIT NONE + INCLUDE 'DIFFSIZES.inc' + CHARACTER UPLO, TRANS, DIAG + INTEGER N, LDA, INCX, NBDIRS + REAL A(LDA,*), AD(NBDIRSMAX,LDA,*) + REAL X(*), XD(NBDIRSMAX,*) + + REAL S(N), T(N), W(N), AD_SLICE(LDA,LDA) + INTEGER ND, I, J, KX + + IF (NBDIRS.LE.0 .OR. NBDIRS.GT.NBDIRSMAX) THEN + WRITE(*,'(A,I0,A,I0,A)') 'Error: nbdirs=', NBDIRS, + + ' must be in 1..nbdirsmax=', NBDIRSMAX, '. Stopping.' + STOP 1 END IF -C - info = 0 - IF (.NOT.LSAME(uplo, 'U') .AND. (.NOT.LSAME(uplo, 'L'))) THEN - info = 1 - ELSE IF (.NOT.LSAME(trans, 'N') .AND. (.NOT.LSAME(trans, 'T')) - + .AND. (.NOT.LSAME(trans, 'C'))) THEN - info = 2 - ELSE IF (.NOT.LSAME(diag, 'U') .AND. (.NOT.LSAME(diag, 'N'))) THEN - info = 3 - ELSE IF (n .LT. 0) THEN - info = 4 + + IF (N.EQ.0) RETURN + + IF (INCX.GE.1) THEN + KX = 1 ELSE - IF (1 .LT. n) THEN - max1 = n - ELSE - max1 = 1 - END IF - IF (lda .LT. max1) THEN - info = 6 - ELSE IF (incx .EQ. 0) THEN - info = 8 - END IF + KX = 1 - (N-1)*INCX END IF - IF (info .NE. 0) THEN - CALL XERBLA('STRSV ', info) - RETURN - ELSE IF (n .EQ. 0) THEN -C -C Quick return if possible. -C - RETURN - ELSE -C - nounit = LSAME(diag, 'N') -C -C Set up the start point in X if the increment is not unity. This -C will be ( N - 1 )*INCX too small for descending loops. -C - IF (incx .LE. 0) THEN - kx = 1 - (n-1)*incx - ELSE IF (incx .NE. 1) THEN - kx = 1 - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through A. -C - IF (LSAME(trans, 'N')) THEN -C -C Form x := inv( A )*x. -C - IF (LSAME(uplo, 'U')) THEN - IF (incx .EQ. 1) THEN - DO j=n,1,-1 - IF (nounit) THEN - temp0 = x(j)/a(j, j) - DO nd=1,nbdirs - xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) - ENDDO - x(j) = temp0 - END IF - DO nd=1,nbdirs - tempd(nd) = xd(nd, j) - ENDDO - temp = x(j) - DO i=j-1,1,-1 - DO nd=1,nbdirs - xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad( - + nd, i, j) - ENDDO - x(i) = x(i) - temp*a(i, j) - ENDDO - ENDDO - ELSE - jx = kx + (n-1)*incx - DO j=n,1,-1 - IF (nounit) THEN - temp0 = x(jx)/a(j, j) - DO nd=1,nbdirs - xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) - ENDDO - x(jx) = temp0 - END IF - DO nd=1,nbdirs - tempd(nd) = xd(nd, jx) - ENDDO - temp = x(jx) - ix = jx - DO i=j-1,1,-1 - ix = ix - incx - DO nd=1,nbdirs - xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp* - + ad(nd, i, j) - ENDDO - x(ix) = x(ix) - temp*a(i, j) - ENDDO - jx = jx - incx - ENDDO - END IF - ELSE IF (incx .EQ. 1) THEN - DO j=1,n - IF (nounit) THEN - temp0 = x(j)/a(j, j) - DO nd=1,nbdirs - xd(nd, j) = (xd(nd, j)-temp0*ad(nd, j, j))/a(j, j) - ENDDO - x(j) = temp0 - END IF - DO nd=1,nbdirs - tempd(nd) = xd(nd, j) - ENDDO - temp = x(j) - DO i=j+1,n - DO nd=1,nbdirs - xd(nd, i) = xd(nd, i) - a(i, j)*tempd(nd) - temp*ad(nd - + , i, j) - ENDDO - x(i) = x(i) - temp*a(i, j) - ENDDO - ENDDO - ELSE - jx = kx - DO j=1,n - IF (nounit) THEN - temp0 = x(jx)/a(j, j) - DO nd=1,nbdirs - xd(nd, jx) = (xd(nd, jx)-temp0*ad(nd, j, j))/a(j, j) - ENDDO - x(jx) = temp0 - END IF - DO nd=1,nbdirs - tempd(nd) = xd(nd, jx) - ENDDO - temp = x(jx) - ix = jx - DO i=j+1,n - ix = ix + incx - DO nd=1,nbdirs - xd(nd, ix) = xd(nd, ix) - a(i, j)*tempd(nd) - temp*ad( - + nd, i, j) - ENDDO - x(ix) = x(ix) - temp*a(i, j) - ENDDO - jx = jx + incx - ENDDO - END IF - ELSE IF (LSAME(uplo, 'U')) THEN -C -C Form x := inv( A**T )*x. -C - IF (incx .EQ. 1) THEN - DO j=1,n - DO nd=1,nbdirs - tempd(nd) = xd(nd, j) - ENDDO - temp = x(j) - DO i=1,j-1 - DO nd=1,nbdirs - tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd - + (nd, i) - ENDDO - temp = temp - a(i, j)*x(i) - ENDDO - IF (nounit) THEN - temp0 = temp/a(j, j) - DO nd=1,nbdirs - tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) - ENDDO - temp = temp0 - END IF - DO nd=1,nbdirs - xd(nd, j) = tempd(nd) - ENDDO - x(j) = temp - ENDDO - ELSE - jx = kx - DO j=1,n - DO nd=1,nbdirs - tempd(nd) = xd(nd, jx) - ENDDO - temp = x(jx) - ix = kx - DO i=1,j-1 - DO nd=1,nbdirs - tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)* - + xd(nd, ix) - ENDDO - temp = temp - a(i, j)*x(ix) - ix = ix + incx - ENDDO - IF (nounit) THEN - temp0 = temp/a(j, j) - DO nd=1,nbdirs - tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) - ENDDO - temp = temp0 - END IF - DO nd=1,nbdirs - xd(nd, jx) = tempd(nd) - ENDDO - x(jx) = temp - jx = jx + incx - ENDDO - END IF - ELSE IF (incx .EQ. 1) THEN - DO j=n,1,-1 - DO nd=1,nbdirs - tempd(nd) = xd(nd, j) - ENDDO - temp = x(j) - DO i=n,j+1,-1 - DO nd=1,nbdirs - tempd(nd) = tempd(nd) - x(i)*ad(nd, i, j) - a(i, j)*xd( - + nd, i) - ENDDO - temp = temp - a(i, j)*x(i) - ENDDO - IF (nounit) THEN - temp0 = temp/a(j, j) - DO nd=1,nbdirs - tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) - ENDDO - temp = temp0 - END IF - DO nd=1,nbdirs - xd(nd, j) = tempd(nd) - ENDDO - x(j) = temp - ENDDO - ELSE - kx = kx + (n-1)*incx - jx = kx - DO j=n,1,-1 - DO nd=1,nbdirs - tempd(nd) = xd(nd, jx) - ENDDO - temp = x(jx) - ix = kx - DO i=n,j+1,-1 - DO nd=1,nbdirs - tempd(nd) = tempd(nd) - x(ix)*ad(nd, i, j) - a(i, j)*xd( - + nd, ix) - ENDDO - temp = temp - a(i, j)*x(ix) - ix = ix - incx - ENDDO - IF (nounit) THEN - temp0 = temp/a(j, j) - DO nd=1,nbdirs - tempd(nd) = (tempd(nd)-temp0*ad(nd, j, j))/a(j, j) - ENDDO - temp = temp0 - END IF - DO nd=1,nbdirs - xd(nd, jx) = tempd(nd) - ENDDO - x(jx) = temp - jx = jx - incx - ENDDO - END IF -C - RETURN -C -C End of STRSV -C - END IF - END + +C S = solution, overwriting X in place (same for every direction) + CALL STRSV(UPLO, TRANS, DIAG, N, A, LDA, X, INCX) + DO I = 1, N + S(I) = X(KX + (I-1)*INCX) + END DO + + DO ND = 1, NBDIRS + + DO J = 1, N + DO I = 1, N + AD_SLICE(I,J) = AD(ND,I,J) + END DO + END DO + +C T = op(Ad)*S (local copy, S stays untouched) + DO I = 1, N + T(I) = S(I) + END DO + CALL STRMV(UPLO, TRANS, DIAG, N, AD_SLICE, LDA, T, 1) + +C RHS = Xd_in - T, gathered respecting INCX + DO I = 1, N + W(I) = XD(ND, KX + (I-1)*INCX) - T(I) + END DO + + CALL STRSV(UPLO, TRANS, DIAG, N, A, LDA, W, 1) + + DO I = 1, N + XD(ND, KX + (I-1)*INCX) = W(I) + END DO + + END DO + + RETURN + END SUBROUTINE STRSV_DV diff --git a/BLAS/test/test_strsm_reverse.f90 b/BLAS/test/test_strsm_reverse.f90 index b047110..602ad46 100644 --- a/BLAS/test/test_strsm_reverse.f90 +++ b/BLAS/test/test_strsm_reverse.f90 @@ -56,7 +56,6 @@ program test_strsm_reverse seed_array = 42 call random_seed(put=seed_array) - ! Initialize primal values side = 'L' uplo = 'U'