diff --git a/.github/workflows/wasm.yml b/.github/workflows/wasm.yml new file mode 100644 index 0000000000..3581e8e3ff --- /dev/null +++ b/.github/workflows/wasm.yml @@ -0,0 +1,68 @@ +name: wasm numerical suite + +on: + push: + paths: + - 'test/wasm/**' + - 'kernel/wasm/**' + - 'kernel/simd/intrin_wasm.h' + - 'kernel/simd/intrin.h' + - 'Makefile.wasm' + - '.github/workflows/wasm.yml' + pull_request: + paths: + - 'test/wasm/**' + - 'kernel/wasm/**' + - 'kernel/simd/intrin_wasm.h' + - 'kernel/simd/intrin.h' + - 'Makefile.wasm' + - '.github/workflows/wasm.yml' + workflow_dispatch: + +concurrency: + group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} + cancel-in-progress: true + +permissions: + contents: read + +jobs: + numerical: + if: github.repository == 'OpenMathLib/OpenBLAS' || github.event_name == 'workflow_dispatch' + runs-on: ubuntu-latest + timeout-minutes: 45 + strategy: + fail-fast: false + matrix: + # Explicit IEEE vs relaxed-SIMD OpenBLAS builds (and matching suite tolerances). + wasm_relaxed_simd: ['0', '1'] + + name: numerical (WASM_RELAXED_SIMD=${{ matrix.wasm_relaxed_simd }}) + + steps: + - name: Checkout repository + uses: actions/checkout@v6 + + - name: Setup Node.js + uses: actions/setup-node@v4 + with: + node-version: '22' + + - name: Setup Emscripten + uses: emscripten-core/setup-emsdk@v16 + with: + version: 4.0.10 + actions-cache-folder: emsdk-cache + + - name: Verify toolchain + run: | + emcc -v + node -v + which emmake emar emranlib + + - name: Run WASM numerical CBLAS suite + env: + WASM_RELAXED_SIMD: ${{ matrix.wasm_relaxed_simd }} + run: | + echo "Running suite with WASM_RELAXED_SIMD=${WASM_RELAXED_SIMD}" + JOBS="$(nproc)" ./test/wasm/run.sh diff --git a/.gitignore b/.gitignore index 53d4941cff..3d6ddb5052 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ *.def *.o *.exe +*.wasm *.out *.tmp lapack-3.1.1 diff --git a/test/wasm/.gitignore b/test/wasm/.gitignore new file mode 100644 index 0000000000..56fb06b83d --- /dev/null +++ b/test/wasm/.gitignore @@ -0,0 +1,4 @@ +out/ +*.js +*.wasm +*.log diff --git a/test/wasm/README.md b/test/wasm/README.md new file mode 100644 index 0000000000..4388f0459a --- /dev/null +++ b/test/wasm/README.md @@ -0,0 +1,70 @@ +# WASM numerical validation suite + +Deep CBLAS correctness checks for `TARGET=WASM128_GENERIC`, run under Node / Emscripten. + +## Oracle + +Results from OpenBLAS (public CBLAS API) are compared to hand-written scalar +C references in `ref_l1.c`, `ref_l2.c`, and `ref_l3.c` (IEEE `*` / `+` only — +no SIMD or FMA intrinsics). This is not Netlib BLAS and not a second OpenBLAS +build. + +Tolerances live in `tol.h`. Builds with `WASM_RELAXED_SIMD=1` use a slightly larger L2/L3 budget (`TEST_WASM_RELAXED`). + +## Run + +```bash +JOBS=20 ./test/wasm/run.sh +``` + +This: + +1. Builds OpenBLAS wasm with `WASM_RELAXED_SIMD=0`, links and runs the suite (IEEE tolerances). +2. Rebuilds with `WASM_RELAXED_SIMD=1`, links and runs again (relaxed tolerances). + +Requires `emcc` on `PATH`, or an emscripten-forge prefix via `OPENBLAS_EM_PREFIX` / auto-discovery used by `benchmark/wasm/build.sh`. + +CI runs the same script via `.github/workflows/wasm.yml` (Emscripten + Node on `ubuntu-latest`) on changes under `test/wasm/` and `kernel/wasm/`. + +## Coverage + +The suite covers the complete standard CBLAS Level 1/2/3 families: + +- Level 1: rotations, swap, scaling, copy, axpy, dot products, norms, absolute + sums, and maximum-index operations for all applicable S/D/C/Z types. +- Level 2 dense: general, symmetric, Hermitian, triangular, and rank-update + operations. +- Level 2 banded and packed: general, symmetric/Hermitian, triangular, solve, + and rank-update operations. +- Level 3: GEMM, SYMM/HEMM, SYRK/HERK, SYR2K/HER2K, and TRMM/TRSM. + +Dense vectors and matrices are filled by `fill_vec_*` / `fill_mat_*` in +`common.h` (existing `fill_f32` / `fill_f64` / `fill_c32` / `fill_c64` wrap +those). Drivers cycle six `FillSpec` cases across the size grid so each +remainder hits a different sign domain and magnitude spread: + +| Domain | Spread | f32 magnitudes | f64 magnitudes | +| --- | --- | --- | --- | +| R⁺ (strictly positive) | near 0 | log-uniform in [1e-4, 1] | [1e-8, 1] | +| R⁺ | far from 0 | [1e2, 1e4] | [1e4, 1e8] | +| R⁻ (strictly negative) | near 0 / far | same magnitudes, negated | same | +| R \ {0} (mixed signs) | near 0 / far | same magnitudes, random sign | same | + +Values are never exactly 0. Near-0 lower bounds stay large enough that +`tol * (1 + maxv)` still flags a wrong kernel; far-from-0 upper bounds stay +small enough that L3 GEMM at n≈129 does not overflow f32. Failure messages +include the active spec (e.g. `R+ far from 0`). + +Triangular solve / multiply fixtures (`make_tri_*`) and band builders stay +O(1) and diagonally dominant so those problems remain well-conditioned. +Symmetric and Hermitian inputs are mirrored explicitly; band and packed +layouts include their off-diagonals. Triangular solves are checked by +constructing a right-hand side with the matching scalar matrix product and +recovering the original input. + +This scope is standard BLAS only. OpenBLAS extensions such as `axpby`, `gemmt`, +`imatcopy`, and bfloat16 routines are intentionally excluded. + +Size grids emphasize tile remainders around 4×4 / 8×4 / 2×2 (see `cases.h`). + +Netlib `ctest` / `utest` remain a separate light gate (`benchmark/wasm/test.sh`). diff --git a/test/wasm/cases.h b/test/wasm/cases.h new file mode 100644 index 0000000000..586a4a6c65 --- /dev/null +++ b/test/wasm/cases.h @@ -0,0 +1,63 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +#ifndef TEST_WASM_CASES_H +#define TEST_WASM_CASES_H + +/* Dense remainders around 4x4 / 8x4 / 2x2 tiles, plus a few larger sizes. */ +static const int SIZES_L1[] = { + 0, 1, 2, 3, 4, 5, 7, 8, 9, 15, 16, 17, 31, 32, 33, 63, 64, 65, + 127, 128, 129, 255, 256, 257, 1023, 1024}; +static const int NS_L1 = (int)(sizeof(SIZES_L1) / sizeof(SIZES_L1[0])); + +static const int SIZES_L2[] = { + 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, + 31, 32, 33, 34, 35, 36, 63, 64, 65, 127, 128, 129}; +static const int NS_L2 = (int)(sizeof(SIZES_L2) / sizeof(SIZES_L2[0])); + +static const int SIZES_L3[] = { + 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, + 31, 32, 33, 34, 35, 36, 63, 64, 65, 127, 128, 129}; +static const int NS_L3 = (int)(sizeof(SIZES_L3) / sizeof(SIZES_L3[0])); + +/* Complex GEMM is heavier; keep max moderate while hitting 2x2 remainders. */ +static const int SIZES_CZ[] = { + 1, 2, 3, 4, 5, 6, 7, 8, 9, 15, 16, 17, 31, 32, 33, 63, 64, 65}; +static const int NS_CZ = (int)(sizeof(SIZES_CZ) / sizeof(SIZES_CZ[0])); + +/* Full standard-BLAS coverage: broad remainder sampling without large cases. */ +static const int SIZES_FULL[] = { + 1, 2, 3, 4, 5, 7, 8, 9, 15, 16, 17, 31, 32}; +static const int NS_FULL = (int)(sizeof(SIZES_FULL) / sizeof(SIZES_FULL[0])); + +static const int INCS[] = {0, 1, 2, 3}; +static const int NINCS = (int)(sizeof(INCS) / sizeof(INCS[0])); + +#endif /* TEST_WASM_CASES_H */ diff --git a/test/wasm/check_l1.c b/test/wasm/check_l1.c new file mode 100644 index 0000000000..231e3ea215 --- /dev/null +++ b/test/wasm/check_l1.c @@ -0,0 +1,1130 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +/* + * Level-1 CBLAS checks vs the scalar oracle in ref_l1.c / ref.c. + * + * Deep SAXPY/DAXPY grids stress tile remainders and strides (SIZES_L1). + * The remaining Level-1 ops run on the compact SIZES_FULL grid. + * + * One static test_* function per public CBLAS interface: allocate, fill, + * call the scalar reference, call OpenBLAS, then expect_close_* / expect_eq_size. + */ + +#include "cases.h" +#include "common.h" +#include "ref.h" +#include "tol.h" + +/* Storage length for an n-vector with stride |inc| (inc==0 → length 1). */ +static int vec_len(int n, int inc) { + int abs_inc = inc == 0 ? 1 : (inc > 0 ? inc : -inc); + if (n <= 0) + return 1; + return inc == 0 ? 1 : n * abs_inc; +} + +/* ------------------------------------------------------------------------- */ +/* Deep AXPY grids (tile remainders + non-unit strides) */ +/* ------------------------------------------------------------------------- */ + +/* saxpy: y := alpha * x + y */ +static void test_saxpy(int n, int incx, int incy) { + int nx = vec_len(n, incx); + int ny = vec_len(n, incy); + float *x = xmalloc((size_t)nx * sizeof(float)); + float *y = xmalloc((size_t)ny * sizeof(float)); + float *yr = xmalloc((size_t)ny * sizeof(float)); + float alpha = 1.1f; + char msg[128]; + + fill_f32(x, nx, 1); + fill_f32(y, ny, 2); + memcpy(yr, y, (size_t)ny * sizeof(float)); + + ref_saxpy(n, alpha, x, incx, yr, incy); + cblas_saxpy(n, alpha, x, incx, y, incy); + + snprintf(msg, sizeof(msg), "saxpy n=%d incx=%d incy=%d", n, incx, incy); + expect_close_f32(msg, y, yr, ny, TOL_S_L1); + + free(x); + free(y); + free(yr); +} + +/* daxpy: y := alpha * x + y */ +static void test_daxpy(int n, int incx, int incy) { + int nx = vec_len(n, incx); + int ny = vec_len(n, incy); + double *x = xmalloc((size_t)nx * sizeof(double)); + double *y = xmalloc((size_t)ny * sizeof(double)); + double *yr = xmalloc((size_t)ny * sizeof(double)); + double alpha = 1.1; + char msg[128]; + + fill_f64(x, nx, 1); + fill_f64(y, ny, 2); + memcpy(yr, y, (size_t)ny * sizeof(double)); + + ref_daxpy(n, alpha, x, incx, yr, incy); + cblas_daxpy(n, alpha, x, incx, y, incy); + + snprintf(msg, sizeof(msg), "daxpy n=%d incx=%d incy=%d", n, incx, incy); + expect_close_f64(msg, y, yr, ny, TOL_D_L1); + + free(x); + free(y); + free(yr); +} + +/* ------------------------------------------------------------------------- */ +/* Real single-precision Level-1 (compact grid, unit / stride-2) */ +/* ------------------------------------------------------------------------- */ + +/* sswap: swap x and y */ +static void test_sswap(int n, int inc) { + int z = n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *xr = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + + fill_f32(x, z, 20); + fill_f32(y, z, 21); + memcpy(xr, x, (size_t)z * sizeof(float)); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l1_swap(n, xr, inc, yr, inc, 1, 0); + cblas_sswap(n, x, inc, y, inc); + + expect_close_f32("sswap", x, xr, z, TOL_S_L1); + expect_close_f32("sswap-y", y, yr, z, TOL_S_L1); + + free(x); + free(y); + free(xr); + free(yr); +} + +/* scopy: y := x */ +static void test_scopy(int n, int inc) { + int z = n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + + fill_f32(x, z, 20); + fill_f32(y, z, 22); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l1_copy(n, x, inc, yr, inc, 1, 0); + cblas_scopy(n, x, inc, y, inc); + + expect_close_f32("scopy", y, yr, z, TOL_S_L1); + + free(x); + free(y); + free(yr); +} + +/* sscal: x := alpha * x */ +static void test_sscal(int n, int inc) { + int z = n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *xr = xmalloc((size_t)z * sizeof(float)); + float a = -0.7f; + + fill_f32(x, z, 20); + memcpy(xr, x, (size_t)z * sizeof(float)); + + ref_l1_scal(n, &a, xr, inc, 1, 0, 1); + cblas_sscal(n, a, x, inc); + + expect_close_f32("sscal", x, xr, z, TOL_S_L1); + + free(x); + free(xr); +} + +/* saxpy on the compact grid (in addition to the deep grid above) */ +static void test_saxpy_compact(int n, int inc) { + int z = n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float a = -0.7f; + + fill_f32(x, z, 23); + fill_f32(y, z, 24); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l1_axpy(n, &a, x, inc, yr, inc, 1, 0); + cblas_saxpy(n, a, x, inc, y, inc); + + expect_close_f32("saxpy-compact", y, yr, z, TOL_S_L1); + + free(x); + free(y); + free(yr); +} + +/* sdot: dot product x^T y */ +static void test_sdot(int n, int inc) { + int z = n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float dr = 0.0f; + float dg; + + fill_f32(x, z, 23); + fill_f32(y, z, 24); + + ref_l1_dot(n, x, inc, y, inc, &dr, 1, 0, 0); + dg = cblas_sdot(n, x, inc, y, inc); + + expect_close_f32("sdot", &dg, &dr, 1, TOL_S_L1 * (n + 1)); + + free(x); + free(y); +} + +/* snrm2: Euclidean norm of x */ +static void test_snrm2(int n, int inc) { + int z = n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float nr; + float ng; + + fill_f32(x, z, 23); + nr = (float)ref_l1_nrm2(n, x, inc, 1, 0); + ng = cblas_snrm2(n, x, inc); + + expect_close_f32("snrm2", &ng, &nr, 1, TOL_S_L1 * (n + 1)); + + free(x); +} + +/* sasum: sum of absolute values of x */ +static void test_sasum(int n, int inc) { + int z = n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float sr; + float sg; + + fill_f32(x, z, 23); + sr = (float)ref_l1_asum(n, x, inc, 1, 0); + sg = cblas_sasum(n, x, inc); + + expect_close_f32("sasum", &sg, &sr, 1, TOL_S_L1 * (n + 1)); + + free(x); +} + +/* isamax: 1-based index of max |x_i| */ +static void test_isamax(int n, int inc) { + int z = n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + size_t ir; + size_t ig; + + fill_f32(x, z, 23); + ir = ref_l1_iamax(n, x, inc, 1, 0); + ig = (size_t)cblas_isamax(n, x, inc); + + expect_eq_size("isamax", ig, ir); + + free(x); +} + +/* ------------------------------------------------------------------------- */ +/* Real double-precision Level-1 */ +/* ------------------------------------------------------------------------- */ + +/* dswap: swap x and y */ +static void test_dswap(int n, int inc) { + int z = n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *xr = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + + fill_f64(x, z, 20); + fill_f64(y, z, 21); + memcpy(xr, x, (size_t)z * sizeof(double)); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l1_swap(n, xr, inc, yr, inc, 1, 1); + cblas_dswap(n, x, inc, y, inc); + + expect_close_f64("dswap", x, xr, z, TOL_D_L1); + expect_close_f64("dswap-y", y, yr, z, TOL_D_L1); + + free(x); + free(y); + free(xr); + free(yr); +} + +/* dcopy: y := x */ +static void test_dcopy(int n, int inc) { + int z = n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + + fill_f64(x, z, 20); + fill_f64(y, z, 22); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l1_copy(n, x, inc, yr, inc, 1, 1); + cblas_dcopy(n, x, inc, y, inc); + + expect_close_f64("dcopy", y, yr, z, TOL_D_L1); + + free(x); + free(y); + free(yr); +} + +/* dscal: x := alpha * x */ +static void test_dscal(int n, int inc) { + int z = n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *xr = xmalloc((size_t)z * sizeof(double)); + double a = -0.7; + + fill_f64(x, z, 20); + memcpy(xr, x, (size_t)z * sizeof(double)); + + ref_l1_scal(n, &a, xr, inc, 1, 1, 1); + cblas_dscal(n, a, x, inc); + + expect_close_f64("dscal", x, xr, z, TOL_D_L1); + + free(x); + free(xr); +} + +/* daxpy on the compact grid */ +static void test_daxpy_compact(int n, int inc) { + int z = n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double a = -0.7; + + fill_f64(x, z, 23); + fill_f64(y, z, 24); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l1_axpy(n, &a, x, inc, yr, inc, 1, 1); + cblas_daxpy(n, a, x, inc, y, inc); + + expect_close_f64("daxpy-compact", y, yr, z, TOL_D_L1); + + free(x); + free(y); + free(yr); +} + +/* ddot: dot product x^T y */ +static void test_ddot(int n, int inc) { + int z = n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double dr = 0.0; + double dg; + + fill_f64(x, z, 23); + fill_f64(y, z, 24); + + ref_l1_dot(n, x, inc, y, inc, &dr, 1, 1, 0); + dg = cblas_ddot(n, x, inc, y, inc); + + expect_close_f64("ddot", &dg, &dr, 1, TOL_D_L1 * (n + 1)); + + free(x); + free(y); +} + +/* dnrm2: Euclidean norm of x */ +static void test_dnrm2(int n, int inc) { + int z = n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double nr; + double ng; + + fill_f64(x, z, 23); + nr = ref_l1_nrm2(n, x, inc, 1, 1); + ng = cblas_dnrm2(n, x, inc); + + expect_close_f64("dnrm2", &ng, &nr, 1, TOL_D_L1 * (n + 1)); + + free(x); +} + +/* dasum: sum of absolute values of x */ +static void test_dasum(int n, int inc) { + int z = n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double sr; + double sg; + + fill_f64(x, z, 23); + sr = ref_l1_asum(n, x, inc, 1, 1); + sg = cblas_dasum(n, x, inc); + + expect_close_f64("dasum", &sg, &sr, 1, TOL_D_L1 * (n + 1)); + + free(x); +} + +/* idamax: 1-based index of max |x_i| */ +static void test_idamax(int n, int inc) { + int z = n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + size_t ir; + size_t ig; + + fill_f64(x, z, 23); + ir = ref_l1_iamax(n, x, inc, 1, 1); + ig = (size_t)cblas_idamax(n, x, inc); + + expect_eq_size("idamax", ig, ir); + + free(x); +} + +/* ------------------------------------------------------------------------- */ +/* Complex single-precision Level-1 (interleaved re,im) */ +/* ------------------------------------------------------------------------- */ + +/* cswap: swap x and y */ +static void test_cswap(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *xr = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + + fill_c32(x, n * inc, 30); + fill_c32(y, n * inc, 31); + memcpy(xr, x, (size_t)z * sizeof(float)); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l1_swap(n, xr, inc, yr, inc, 2, 0); + cblas_cswap(n, x, inc, y, inc); + + expect_close_f32("cswap", x, xr, z, TOL_S_L1); + expect_close_f32("cswap-y", y, yr, z, TOL_S_L1); + + free(x); + free(y); + free(xr); + free(yr); +} + +/* ccopy: y := x */ +static void test_ccopy(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + + fill_c32(x, n * inc, 30); + fill_c32(y, n * inc, 32); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l1_copy(n, x, inc, yr, inc, 2, 0); + cblas_ccopy(n, x, inc, y, inc); + + expect_close_f32("ccopy", y, yr, z, TOL_S_L1); + + free(x); + free(y); + free(yr); +} + +/* cscal: x := alpha * x (complex alpha) */ +static void test_cscal(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *xr = xmalloc((size_t)z * sizeof(float)); + float a[2] = {-0.7f, 0.2f}; + + fill_c32(x, n * inc, 30); + memcpy(xr, x, (size_t)z * sizeof(float)); + + ref_l1_scal(n, a, xr, inc, 2, 0, 0); + cblas_cscal(n, a, x, inc); + + expect_close_f32("cscal", x, xr, z, TOL_S_L1); + + free(x); + free(xr); +} + +/* csscal: x := alpha * x (real alpha) */ +static void test_csscal(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *xr = xmalloc((size_t)z * sizeof(float)); + float a[2] = {-0.7f, 0.2f}; + + fill_c32(x, n * inc, 32); + memcpy(xr, x, (size_t)z * sizeof(float)); + + ref_l1_scal(n, a, xr, inc, 2, 0, 1); + cblas_csscal(n, a[0], x, inc); + + expect_close_f32("csscal", x, xr, z, TOL_S_L1); + + free(x); + free(xr); +} + +/* caxpy: y := alpha * x + y */ +static void test_caxpy(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float a[2] = {-0.7f, 0.2f}; + + fill_c32(x, n * inc, 30); + fill_c32(y, n * inc, 33); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l1_axpy(n, a, x, inc, yr, inc, 2, 0); + cblas_caxpy(n, a, x, inc, y, inc); + + expect_close_f32("caxpy", y, yr, z, TOL_S_L1); + + free(x); + free(y); + free(yr); +} + +/* cdotu_sub: unconjugated complex dot product */ +static void test_cdotu_sub(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float ru[2] = {0.0f, 0.0f}; + float gu[2] = {0.0f, 0.0f}; + + fill_c32(x, n * inc, 30); + fill_c32(y, n * inc, 33); + + ref_l1_dot(n, x, inc, y, inc, ru, 2, 0, 0); + cblas_cdotu_sub(n, x, inc, y, inc, gu); + + expect_close_f32("cdotu", gu, ru, 2, TOL_S_L1 * (n + 1)); + + free(x); + free(y); +} + +/* cdotc_sub: conjugated complex dot product */ +static void test_cdotc_sub(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float rc[2] = {0.0f, 0.0f}; + float gc[2] = {0.0f, 0.0f}; + + fill_c32(x, n * inc, 30); + fill_c32(y, n * inc, 33); + + ref_l1_dot(n, x, inc, y, inc, rc, 2, 0, 1); + cblas_cdotc_sub(n, x, inc, y, inc, gc); + + expect_close_f32("cdotc", gc, rc, 2, TOL_S_L1 * (n + 1)); + + free(x); + free(y); +} + +/* scnrm2: Euclidean norm of a complex vector */ +static void test_scnrm2(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float nr; + float ng; + + fill_c32(x, n * inc, 30); + nr = (float)ref_l1_nrm2(n, x, inc, 2, 0); + ng = cblas_scnrm2(n, x, inc); + + expect_close_f32("scnrm2", &ng, &nr, 1, TOL_S_L1 * (n + 1)); + + free(x); +} + +/* scasum: sum of |re| + |im| over a complex vector */ +static void test_scasum(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + float sr; + float sg; + + fill_c32(x, n * inc, 30); + sr = (float)ref_l1_asum(n, x, inc, 2, 0); + sg = cblas_scasum(n, x, inc); + + expect_close_f32("scasum", &sg, &sr, 1, TOL_S_L1 * (n + 1)); + + free(x); +} + +/* icamax: 1-based index of max |z_i| */ +static void test_icamax(int n, int inc) { + int z = 2 * n * inc; + float *x = xmalloc((size_t)z * sizeof(float)); + size_t ir; + size_t ig; + + fill_c32(x, n * inc, 30); + ir = ref_l1_iamax(n, x, inc, 2, 0); + ig = (size_t)cblas_icamax(n, x, inc); + + expect_eq_size("icamax", ig, ir); + + free(x); +} + +/* ------------------------------------------------------------------------- */ +/* Complex double-precision Level-1 */ +/* ------------------------------------------------------------------------- */ + +/* zswap: swap x and y */ +static void test_zswap(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *xr = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + + fill_c64(x, n * inc, 40); + fill_c64(y, n * inc, 41); + memcpy(xr, x, (size_t)z * sizeof(double)); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l1_swap(n, xr, inc, yr, inc, 2, 1); + cblas_zswap(n, x, inc, y, inc); + + expect_close_f64("zswap", x, xr, z, TOL_D_L1); + expect_close_f64("zswap-y", y, yr, z, TOL_D_L1); + + free(x); + free(y); + free(xr); + free(yr); +} + +/* zcopy: y := x */ +static void test_zcopy(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + + fill_c64(x, n * inc, 40); + fill_c64(y, n * inc, 41); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l1_copy(n, x, inc, yr, inc, 2, 1); + cblas_zcopy(n, x, inc, y, inc); + + expect_close_f64("zcopy", y, yr, z, TOL_D_L1); + + free(x); + free(y); + free(yr); +} + +/* zscal: x := alpha * x (complex alpha) */ +static void test_zscal(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *xr = xmalloc((size_t)z * sizeof(double)); + double a[2] = {-0.7, 0.2}; + + fill_c64(x, n * inc, 40); + memcpy(xr, x, (size_t)z * sizeof(double)); + + ref_l1_scal(n, a, xr, inc, 2, 1, 0); + cblas_zscal(n, a, x, inc); + + expect_close_f64("zscal", x, xr, z, TOL_D_L1); + + free(x); + free(xr); +} + +/* zdscal: x := alpha * x (real alpha) */ +static void test_zdscal(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *xr = xmalloc((size_t)z * sizeof(double)); + double a[2] = {-0.7, 0.2}; + + fill_c64(x, n * inc, 42); + memcpy(xr, x, (size_t)z * sizeof(double)); + + ref_l1_scal(n, a, xr, inc, 2, 1, 1); + cblas_zdscal(n, a[0], x, inc); + + expect_close_f64("zdscal", x, xr, z, TOL_D_L1); + + free(x); + free(xr); +} + +/* zaxpy: y := alpha * x + y */ +static void test_zaxpy(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double a[2] = {-0.7, 0.2}; + + fill_c64(x, n * inc, 40); + fill_c64(y, n * inc, 43); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l1_axpy(n, a, x, inc, yr, inc, 2, 1); + cblas_zaxpy(n, a, x, inc, y, inc); + + expect_close_f64("zaxpy", y, yr, z, TOL_D_L1); + + free(x); + free(y); + free(yr); +} + +/* zdotu_sub: unconjugated complex dot product */ +static void test_zdotu_sub(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double ru[2] = {0.0, 0.0}; + double gu[2] = {0.0, 0.0}; + + fill_c64(x, n * inc, 40); + fill_c64(y, n * inc, 43); + + ref_l1_dot(n, x, inc, y, inc, ru, 2, 1, 0); + cblas_zdotu_sub(n, x, inc, y, inc, gu); + + expect_close_f64("zdotu", gu, ru, 2, TOL_D_L1 * (n + 1)); + + free(x); + free(y); +} + +/* zdotc_sub: conjugated complex dot product */ +static void test_zdotc_sub(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double rc[2] = {0.0, 0.0}; + double gc[2] = {0.0, 0.0}; + + fill_c64(x, n * inc, 40); + fill_c64(y, n * inc, 43); + + ref_l1_dot(n, x, inc, y, inc, rc, 2, 1, 1); + cblas_zdotc_sub(n, x, inc, y, inc, gc); + + expect_close_f64("zdotc", gc, rc, 2, TOL_D_L1 * (n + 1)); + + free(x); + free(y); +} + +/* dznrm2: Euclidean norm of a complex vector */ +static void test_dznrm2(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double nr; + double ng; + + fill_c64(x, n * inc, 40); + nr = ref_l1_nrm2(n, x, inc, 2, 1); + ng = cblas_dznrm2(n, x, inc); + + expect_close_f64("dznrm2", &ng, &nr, 1, TOL_D_L1 * (n + 1)); + + free(x); +} + +/* dzasum: sum of |re| + |im| over a complex vector */ +static void test_dzasum(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + double sr; + double sg; + + fill_c64(x, n * inc, 40); + sr = ref_l1_asum(n, x, inc, 2, 1); + sg = cblas_dzasum(n, x, inc); + + expect_close_f64("dzasum", &sg, &sr, 1, TOL_D_L1 * (n + 1)); + + free(x); +} + +/* izamax: 1-based index of max |z_i| */ +static void test_izamax(int n, int inc) { + int z = 2 * n * inc; + double *x = xmalloc((size_t)z * sizeof(double)); + size_t ir; + size_t ig; + + fill_c64(x, n * inc, 40); + ir = ref_l1_iamax(n, x, inc, 2, 1); + ig = (size_t)cblas_izamax(n, x, inc); + + expect_eq_size("izamax", ig, ir); + + free(x); +} + +/* ------------------------------------------------------------------------- */ +/* Rotations */ +/* ------------------------------------------------------------------------- */ + +/* srot: plane rotation of (x, y) */ +static void test_srot(int n) { + int k = n > 32 ? 32 : n; + float x[64], y[64], xr[64], yr[64]; + + fill_f32(x, k, 50); + fill_f32(y, k, 51); + memcpy(xr, x, (size_t)k * sizeof(float)); + memcpy(yr, y, (size_t)k * sizeof(float)); + + ref_l1_rot(k, xr, 1, yr, 1, 0.8, 0.6, 1, 0); + cblas_srot(k, x, 1, y, 1, 0.8f, 0.6f); + + expect_close_f32("srot", x, xr, k, TOL_S_L1); + expect_close_f32("srot-y", y, yr, k, TOL_S_L1); +} + +/* drot: plane rotation of (x, y) */ +static void test_drot(int n) { + int k = n > 32 ? 32 : n; + double x[64], y[64], xr[64], yr[64]; + + fill_f64(x, k, 50); + fill_f64(y, k, 51); + memcpy(xr, x, (size_t)k * sizeof(double)); + memcpy(yr, y, (size_t)k * sizeof(double)); + + ref_l1_rot(k, xr, 1, yr, 1, 0.8, 0.6, 1, 1); + cblas_drot(k, x, 1, y, 1, 0.8, 0.6); + + expect_close_f64("drot", x, xr, k, TOL_D_L1); + expect_close_f64("drot-y", y, yr, k, TOL_D_L1); +} + +/* srotm: modified Givens rotation of (x, y) */ +static void test_srotm(int n) { + int k = n > 32 ? 32 : n; + float x[64], y[64], xr[64], yr[64]; + float p[5] = {-1.0f, 0.8f, -0.2f, 0.3f, 1.1f}; + + fill_f32(x, k, 52); + fill_f32(y, k, 53); + memcpy(xr, x, (size_t)k * sizeof(float)); + memcpy(yr, y, (size_t)k * sizeof(float)); + + ref_l1_rotm(k, xr, 1, yr, 1, p, 0); + cblas_srotm(k, x, 1, y, 1, p); + + expect_close_f32("srotm", x, xr, k, TOL_S_L1); + expect_close_f32("srotm-y", y, yr, k, TOL_S_L1); +} + +/* drotm: modified Givens rotation of (x, y) */ +static void test_drotm(int n) { + int k = n > 32 ? 32 : n; + double x[64], y[64], xr[64], yr[64]; + double p[5] = {-1.0, 0.8, -0.2, 0.3, 1.1}; + + fill_f64(x, k, 52); + fill_f64(y, k, 53); + memcpy(xr, x, (size_t)k * sizeof(double)); + memcpy(yr, y, (size_t)k * sizeof(double)); + + ref_l1_rotm(k, xr, 1, yr, 1, p, 1); + cblas_drotm(k, x, 1, y, 1, p); + + expect_close_f64("drotm", x, xr, k, TOL_D_L1); + expect_close_f64("drotm-y", y, yr, k, TOL_D_L1); +} + +/* csrot: real plane rotation applied to complex vectors */ +static void test_csrot(int n) { + int k = n > 32 ? 32 : n; + float x[128], y[128], xr[128], yr[128]; + + fill_c32(x, k, 54); + fill_c32(y, k, 55); + memcpy(xr, x, (size_t)2 * k * sizeof(float)); + memcpy(yr, y, (size_t)2 * k * sizeof(float)); + + ref_l1_rot(k, xr, 1, yr, 1, 0.8, 0.6, 2, 0); + cblas_csrot(k, x, 1, y, 1, 0.8f, 0.6f); + + expect_close_f32("csrot", x, xr, 2 * k, TOL_S_L1); + expect_close_f32("csrot-y", y, yr, 2 * k, TOL_S_L1); +} + +/* zdrot: real plane rotation applied to complex vectors */ +static void test_zdrot(int n) { + int k = n > 32 ? 32 : n; + double x[128], y[128], xr[128], yr[128]; + + fill_c64(x, k, 54); + fill_c64(y, k, 55); + memcpy(xr, x, (size_t)2 * k * sizeof(double)); + memcpy(yr, y, (size_t)2 * k * sizeof(double)); + + ref_l1_rot(k, xr, 1, yr, 1, 0.8, 0.6, 2, 1); + cblas_zdrot(k, x, 1, y, 1, 0.8, 0.6); + + expect_close_f64("zdrot", x, xr, 2 * k, TOL_D_L1); + expect_close_f64("zdrot-y", y, yr, 2 * k, TOL_D_L1); +} + +/* srotg: generate a real Givens rotation (residual check) */ +static void test_srotg(void) { + float a = 3.0f, b = 4.0f, c = 0.0f, s = 0.0f; + float e; + float zero = 0.0f; + + cblas_srotg(&a, &b, &c, &s); + e = (c * 3.0f + s * 4.0f) - a; + expect_close_f32("srotg", &e, &zero, 1, TOL_S_L1 * 8); +} + +/* drotg: generate a real Givens rotation (residual check) */ +static void test_drotg(void) { + double a = 3.0, b = 4.0, c = 0.0, s = 0.0; + double e; + double zero = 0.0; + + cblas_drotg(&a, &b, &c, &s); + e = (c * 3.0 + s * 4.0) - a; + expect_close_f64("drotg", &e, &zero, 1, TOL_D_L1 * 8); +} + +/* crotg: generate a complex Givens rotation (residual check) */ +static void test_crotg(void) { + float a[2] = {3.0f, 1.0f}, b[2] = {2.0f, -1.0f}, s[2] = {0.0f, 0.0f}; + float c = 0.0f; + float e0, e1, e; + float zero = 0.0f; + + cblas_crotg(a, b, &c, s); + e0 = -(s[0] * 3.0f + s[1] * 1.0f) + c * 2.0f; + e1 = -(-s[1] * 3.0f + s[0] * 1.0f) - c; + e = fabsf(e0) + fabsf(e1); + expect_close_f32("crotg", &e, &zero, 1, TOL_S_L1 * 16); +} + +/* zrotg: generate a complex Givens rotation (residual check) */ +static void test_zrotg(void) { + double a[2] = {3.0, 1.0}, b[2] = {2.0, -1.0}, s[2] = {0.0, 0.0}; + double c = 0.0; + double e0, e1, e; + double zero = 0.0; + + cblas_zrotg(a, b, &c, s); + e0 = -(s[0] * 3.0 + s[1] * 1.0) + c * 2.0; + e1 = -(-s[1] * 3.0 + s[0] * 1.0) - c; + e = fabs(e0) + fabs(e1); + expect_close_f64("zrotg", &e, &zero, 1, TOL_D_L1 * 16); +} + +/* srotmg: generate a modified Givens transformation */ +static void test_srotmg(void) { + float d1 = 1.0f, d2 = 2.0f, b1 = 3.0f, b2 = 4.0f, p[5] = {9, 9, 9, 9, 9}; + float rd1 = 1.0f, rd2 = 2.0f, rb1 = 3.0f, rp[5] = {9, 9, 9, 9, 9}; + float got[8], ref[8]; + + ref_l1_rotmg(&rd1, &rd2, &rb1, &b2, rp, 0); + cblas_srotmg(&d1, &d2, &b1, b2, p); + + got[0] = d1; + got[1] = d2; + got[2] = b1; + got[3] = p[0]; + got[4] = p[1]; + got[5] = p[2]; + got[6] = p[3]; + got[7] = p[4]; + ref[0] = rd1; + ref[1] = rd2; + ref[2] = rb1; + ref[3] = rp[0]; + ref[4] = rp[1]; + ref[5] = rp[2]; + ref[6] = rp[3]; + ref[7] = rp[4]; + + expect_close_f32("srotmg", got, ref, 8, TOL_S_L1 * 16); +} + +/* drotmg: generate a modified Givens transformation */ +static void test_drotmg(void) { + double d1 = 1.0, d2 = 2.0, b1 = 3.0, b2 = 4.0, p[5] = {9, 9, 9, 9, 9}; + double rd1 = 1.0, rd2 = 2.0, rb1 = 3.0, rp[5] = {9, 9, 9, 9, 9}; + double got[8], ref[8]; + + ref_l1_rotmg(&rd1, &rd2, &rb1, &b2, rp, 1); + cblas_drotmg(&d1, &d2, &b1, b2, p); + + got[0] = d1; + got[1] = d2; + got[2] = b1; + got[3] = p[0]; + got[4] = p[1]; + got[5] = p[2]; + got[6] = p[3]; + got[7] = p[4]; + ref[0] = rd1; + ref[1] = rd2; + ref[2] = rb1; + ref[3] = rp[0]; + ref[4] = rp[1]; + ref[5] = rp[2]; + ref[6] = rp[3]; + ref[7] = rp[4]; + + expect_close_f64("drotmg", got, ref, 8, TOL_D_L1 * 16); +} + +/* ------------------------------------------------------------------------- */ +/* Drivers */ +/* ------------------------------------------------------------------------- */ + +static void run_deep_axpy(void) { + printf("==> L1 AXPY (deep remainder / stride grid)\n"); + for (int s = 0; s < NS_L1; s++) { + int n = SIZES_L1[s]; + use_fill_case(s); + test_saxpy(n, 1, 1); + test_daxpy(n, 1, 1); + for (int i = 0; i < NINCS; i++) { + int inc = INCS[i]; + if (inc == 1) + continue; + test_saxpy(n, inc, inc); + test_daxpy(n, inc, inc); + } + } +} + +static void run_compact_l1(void) { + printf("==> L1 compact S/D/C/Z + rotations\n"); + + test_srotg(); + test_drotg(); + test_crotg(); + test_zrotg(); + test_srotmg(); + test_drotmg(); + + for (int i = 0; i < NS_FULL; i++) { + int n = SIZES_FULL[i]; + int incs[2] = {1, 2}; + use_fill_case(i); + + for (int j = 0; j < 2; j++) { + int inc = incs[j]; + + test_sswap(n, inc); + test_scopy(n, inc); + test_sscal(n, inc); + test_saxpy_compact(n, inc); + test_sdot(n, inc); + test_snrm2(n, inc); + test_sasum(n, inc); + test_isamax(n, inc); + + test_dswap(n, inc); + test_dcopy(n, inc); + test_dscal(n, inc); + test_daxpy_compact(n, inc); + test_ddot(n, inc); + test_dnrm2(n, inc); + test_dasum(n, inc); + test_idamax(n, inc); + + test_cswap(n, inc); + test_ccopy(n, inc); + test_cscal(n, inc); + test_csscal(n, inc); + test_caxpy(n, inc); + test_cdotu_sub(n, inc); + test_cdotc_sub(n, inc); + test_scnrm2(n, inc); + test_scasum(n, inc); + test_icamax(n, inc); + + test_zswap(n, inc); + test_zcopy(n, inc); + test_zscal(n, inc); + test_zdscal(n, inc); + test_zaxpy(n, inc); + test_zdotu_sub(n, inc); + test_zdotc_sub(n, inc); + test_dznrm2(n, inc); + test_dzasum(n, inc); + test_izamax(n, inc); + } + + test_srot(n); + test_drot(n); + test_srotm(n); + test_drotm(n); + test_csrot(n); + test_zdrot(n); + } +} + +void check_l1(void) { + run_deep_axpy(); + run_compact_l1(); +} diff --git a/test/wasm/check_l2.c b/test/wasm/check_l2.c new file mode 100644 index 0000000000..ac207f2077 --- /dev/null +++ b/test/wasm/check_l2.c @@ -0,0 +1,2769 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +/* + * Level-2 CBLAS checks vs the scalar oracle in ref_l2.c / ref.c. + * + * A deep SGEMV/DGEMV grid stresses tile remainders, rectangular shapes, + * transposes and non-unit strides (SIZES_L2). Every other Level-2 op -- + * dense, banded and packed, for s/d/c/z -- runs on the compact SIZES_FULL + * grid, where the matrices stay small enough to build by hand. + * + * One static test_* function per public CBLAS interface: allocate, fill, + * call the scalar reference, call OpenBLAS, then expect_close_*. + * + * Matrices are column major throughout. Complex data is interleaved re,im, + * so a complex n-vector occupies 2*n floats/doubles and the element (i, j) + * of an n-by-n matrix starts at index 2*(i + j*n). + */ + +#include "cases.h" +#include "common.h" +#include "ref.h" +#include "tol.h" + +/* ------------------------------------------------------------------------- */ +/* Shared helpers */ +/* ------------------------------------------------------------------------- */ + +/* Storage length for an n-vector with stride |inc| (inc==0 → length 1). */ +static int vec_len(int n, int inc) { + int abs_inc = inc == 0 ? 1 : (inc > 0 ? inc : -inc); + + if (n <= 0) + return 1; + return inc == 0 ? 1 : n * abs_inc; +} + +/* Level-2 tolerance grows with n; tag the failure message with the size. */ +static void expect_l2_f32(const char *op, int n, const float *got, + const float *ref, int z) { + char msg[96]; + + snprintf(msg, sizeof(msg), "%s n=%d", op, n); + expect_close_f32(msg, got, ref, z, tol_s_l2(n)); +} + +static void expect_l2_f64(const char *op, int n, const double *got, + const double *ref, int z) { + char msg[96]; + + snprintf(msg, sizeof(msg), "%s n=%d", op, n); + expect_close_f64(msg, got, ref, z, tol_d_l2(n)); +} + +/* Half-bandwidth used by the banded tests: 3, or n-1 for the tiny sizes. */ +static int band_width(int n) { return n > 3 ? 3 : n - 1; } + +/* Index of element (i, j), i >= j, in a column-major packed lower triangle. */ +static int packed_lower(int i, int j, int n) { + return i + (2 * n - j - 1) * j / 2; +} + +/* ------------------------------------------------------------------------- */ +/* Deep GEMV grids (shapes, transposes, strides) */ +/* ------------------------------------------------------------------------- */ + +/* sgemv: y := alpha*op(A)*x + beta*y */ +static void test_sgemv(enum CBLAS_TRANSPOSE trans, int m, int n, int incx, + int incy) { + int lda = m; + int lenx = (trans == CblasNoTrans) ? n : m; + int leny = (trans == CblasNoTrans) ? m : n; + int nx = vec_len(lenx, incx); + int ny = vec_len(leny, incy); + float *A = xmalloc((size_t)lda * (size_t)n * sizeof(float)); + float *x = xmalloc((size_t)nx * sizeof(float)); + float *y = xmalloc((size_t)ny * sizeof(float)); + float *yr = xmalloc((size_t)ny * sizeof(float)); + float alpha = 1.1f; + float beta = 0.7f; + char msg[160]; + + fill_f32(A, lda * n, 3); + fill_f32(x, nx, 4); + fill_f32(y, ny, 5); + memcpy(yr, y, (size_t)ny * sizeof(float)); + + ref_sgemv(trans, m, n, alpha, A, lda, x, incx, beta, yr, incy); + cblas_sgemv(CblasColMajor, trans, m, n, alpha, A, lda, x, incx, beta, y, + incy); + + snprintf(msg, sizeof(msg), "sgemv t=%d m=%d n=%d incx=%d incy=%d", (int)trans, + m, n, incx, incy); + expect_close_f32(msg, y, yr, ny, tol_s_l2(m > n ? m : n)); + + free(A); + free(x); + free(y); + free(yr); +} + +/* dgemv: y := alpha*op(A)*x + beta*y */ +static void test_dgemv(enum CBLAS_TRANSPOSE trans, int m, int n, int incx, + int incy) { + int lda = m; + int lenx = (trans == CblasNoTrans) ? n : m; + int leny = (trans == CblasNoTrans) ? m : n; + int nx = vec_len(lenx, incx); + int ny = vec_len(leny, incy); + double *A = xmalloc((size_t)lda * (size_t)n * sizeof(double)); + double *x = xmalloc((size_t)nx * sizeof(double)); + double *y = xmalloc((size_t)ny * sizeof(double)); + double *yr = xmalloc((size_t)ny * sizeof(double)); + double alpha = 1.1; + double beta = 0.7; + char msg[160]; + + fill_f64(A, lda * n, 3); + fill_f64(x, nx, 4); + fill_f64(y, ny, 5); + memcpy(yr, y, (size_t)ny * sizeof(double)); + + ref_dgemv(trans, m, n, alpha, A, lda, x, incx, beta, yr, incy); + cblas_dgemv(CblasColMajor, trans, m, n, alpha, A, lda, x, incx, beta, y, + incy); + + snprintf(msg, sizeof(msg), "dgemv t=%d m=%d n=%d incx=%d incy=%d", (int)trans, + m, n, incx, incy); + expect_close_f64(msg, y, yr, ny, tol_d_l2(m > n ? m : n)); + + free(A); + free(x); + free(y); + free(yr); +} + +/* ------------------------------------------------------------------------- */ +/* Real single-precision matrix builders */ +/* ------------------------------------------------------------------------- */ + +/* Mirror the lower triangle of A into the strict upper one. */ +static void symmetrize_f32(float *A, int n) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) + A[i + j * n] = A[j + i * n]; +} + +/* A pseudo-random symmetric matrix. */ +static void make_sym_f32(float *A, int n, int seed) { + fill_f32(A, n * n, seed); + symmetrize_f32(A, n); +} + +/* Drop the strict upper triangle, keeping the lower triangular part. */ +static void zero_upper_f32(float *A, int n) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) + A[i + j * n] = 0.0f; +} + +/* Copy the lower triangle of A into packed storage. */ +static void pack_lower_f32(float *ap, const float *A, int n) { + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) + ap[packed_lower(i, j, n)] = A[i + j * n]; +} + +/* A general band matrix, both dense (A) and in (kl=ku=k) band storage (ab), + * where band element (i, j) lives at ab[k + i - j + j*ldab], ldab = 2*k + 1. */ +static void make_gband_f32(float *A, float *ab, int n, int k) { + int ldab = 2 * k + 1; + + memset(A, 0, (size_t)n * n * sizeof(float)); + memset(ab, 0, (size_t)ldab * n * sizeof(float)); + for (int j = 0; j < n; j++) + for (int i = j - k; i <= j + k; i++) { + float v; + + if (i < 0 || i >= n) + continue; + v = 0.15f + 0.01f * (float)(i + 2 * j); + A[i + j * n] = v; + ab[k + i - j + j * ldab] = v; + } +} + +/* A symmetric band matrix, both dense (A) and in lower band storage (ab), + * where band element (i, j) lives at ab[i - j + j*ldab], ldab = k + 1. + * The diagonal is 2, so the lower triangle is safe to invert in TBSV. */ +static void make_sband_f32(float *A, float *ab, int n, int k) { + int ldab = k + 1; + + memset(A, 0, (size_t)n * n * sizeof(float)); + memset(ab, 0, (size_t)ldab * n * sizeof(float)); + for (int j = 0; j < n; j++) + for (int i = j; i <= j + k && i < n; i++) { + float v = (i == j) ? 2.0f : 0.1f + 0.01f * (float)(i + j); + + A[i + j * n] = v; + A[j + i * n] = v; + ab[i - j + j * ldab] = v; + } +} + +/* Packed lower triangle of alpha*x*x^T, the SPR reference. */ +static void ref_spr_f32(float *ap, const float *x, int n, float alpha) { + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) + ap[packed_lower(i, j, n)] = alpha * x[i] * x[j]; +} + +/* ------------------------------------------------------------------------- */ +/* Real single-precision Level-2 (compact grid) */ +/* ------------------------------------------------------------------------- */ + +/* sgemv: y := alpha*A*x + beta*y */ +static void test_sgemv_compact(int n) { + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + float beta = -0.3f; + + make_sym_f32(A, n, 60); + fill_f32(x, n, 61); + fill_f32(y, n, 62); + memcpy(yr, y, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 0, 0); + cblas_sgemv(CblasColMajor, CblasNoTrans, n, n, alpha, A, n, x, 1, beta, y, 1); + + expect_l2_f32("sgemv", n, y, yr, n); + + free(A); + free(x); + free(y); + free(yr); +} + +/* ssymv: y := alpha*A*x + beta*y, symmetric A read from its lower triangle */ +static void test_ssymv(int n) { + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + float beta = -0.3f; + + make_sym_f32(A, n, 60); + fill_f32(x, n, 61); + fill_f32(y, n, 63); + memcpy(yr, y, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 0, 0); + cblas_ssymv(CblasColMajor, CblasLower, n, alpha, A, n, x, 1, beta, y, 1); + + expect_l2_f32("ssymv", n, y, yr, n); + + free(A); + free(x); + free(y); + free(yr); +} + +/* strmv: x := A*x, A lower triangular with a non-unit diagonal */ +static void test_strmv(int n) { + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float one = 1.0f; + float zero = 0.0f; + + make_tri_f32(A, n, n, CblasLower, 0); + fill_f32(x, n, 61); + memcpy(y, x, (size_t)n * sizeof(float)); + memset(yr, 0, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &one, &zero, 1, 0, 0); + cblas_strmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, A, n, y, + 1); + + expect_l2_f32("strmv", n, y, yr, n); + + free(A); + free(x); + free(y); + free(yr); +} + +/* strsv: solve A*y = A*x on the same triangle, so y must come back as x */ +static void test_strsv(int n) { + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float one = 1.0f; + float zero = 0.0f; + + make_tri_f32(A, n, n, CblasLower, 0); + fill_f32(x, n, 61); + memset(y, 0, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, y, &one, &zero, 1, 0, 0); + cblas_strsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, A, n, y, + 1); + + expect_l2_f32("strsv", n, y, x, n); + + free(A); + free(x); + free(y); +} + +/* strmv: x := A^T*x, A upper triangular with an implicit unit diagonal. + * The reference takes the transpose through its "conjugate" flag, which for + * real data is a plain transpose. */ +static void test_strmv_upper_unit(int n) { + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float one = 1.0f; + float zero = 0.0f; + + make_tri_f32(A, n, n, CblasUpper, 1); + fill_f32(x, n, 61); + memcpy(y, x, (size_t)n * sizeof(float)); + memset(yr, 0, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &one, &zero, 1, 0, 1); + cblas_strmv(CblasColMajor, CblasUpper, CblasTrans, CblasUnit, n, A, n, y, 1); + + expect_l2_f32("strmv-upper-unit", n, y, yr, n); + + free(A); + free(x); + free(y); + free(yr); +} + +/* strsv: solve A^T*y = A^T*x on the upper unit triangle */ +static void test_strsv_upper_unit(int n) { + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float one = 1.0f; + float zero = 0.0f; + + make_tri_f32(A, n, n, CblasUpper, 1); + fill_f32(x, n, 61); + memset(y, 0, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, y, &one, &zero, 1, 0, 1); + cblas_strsv(CblasColMajor, CblasUpper, CblasTrans, CblasUnit, n, A, n, y, 1); + + expect_l2_f32("strsv-upper-unit", n, y, x, n); + + free(A); + free(x); + free(y); +} + +/* sger: A := alpha*x*y^T + A, starting from a zero A */ +static void test_sger(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *Ar = xmalloc((size_t)nn * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + + fill_f32(x, n, 61); + fill_f32(y, n, 68); + memset(A, 0, (size_t)nn * sizeof(float)); + memset(Ar, 0, (size_t)nn * sizeof(float)); + + ref_l2_rank(n, Ar, x, y, &alpha, 1, 0, 0, 0, 0); + cblas_sger(CblasColMajor, n, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f32("sger", n, A, Ar, nn); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* ssyr: A := alpha*x*x^T + A, lower triangle only */ +static void test_ssyr(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *Ar = xmalloc((size_t)nn * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + + fill_f32(x, n, 61); + memset(A, 0, (size_t)nn * sizeof(float)); + memset(Ar, 0, (size_t)nn * sizeof(float)); + + ref_l2_rank(n, Ar, x, x, &alpha, 1, 0, 0, 1, 0); + cblas_ssyr(CblasColMajor, CblasLower, n, alpha, x, 1, A, n); + + expect_l2_f32("ssyr", n, A, Ar, nn); + + free(A); + free(Ar); + free(x); +} + +/* ssyr2: A := alpha*(x*y^T + y*x^T) + A, lower triangle only. + * A starts from a rank-1 update so the update is checked as an accumulation. */ +static void test_ssyr2(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *Ar = xmalloc((size_t)nn * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + + fill_f32(x, n, 61); + fill_f32(y, n, 68); + memset(Ar, 0, (size_t)nn * sizeof(float)); + ref_l2_rank(n, Ar, x, x, &alpha, 1, 0, 0, 1, 0); + memcpy(A, Ar, (size_t)nn * sizeof(float)); + + ref_l2_rank(n, Ar, x, y, &alpha, 1, 0, 0, 1, 0); + ref_l2_rank(n, Ar, y, x, &alpha, 1, 0, 0, 1, 0); + cblas_ssyr2(CblasColMajor, CblasLower, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f32("ssyr2", n, A, Ar, nn); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* sgbmv: y := alpha*A*x + beta*y with A in general band storage */ +static void test_sgbmv(int n) { + int k = band_width(n); + int ldab = 2 * k + 1; + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *ab = xmalloc((size_t)ldab * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + float beta = -0.3f; + + make_gband_f32(A, ab, n, k); + fill_f32(x, n, 61); + fill_f32(y, n, 64); + memcpy(yr, y, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 0, 0); + cblas_sgbmv(CblasColMajor, CblasNoTrans, n, n, k, k, alpha, ab, ldab, x, 1, + beta, y, 1); + + expect_l2_f32("sgbmv", n, y, yr, n); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* ssbmv: y := alpha*A*x + beta*y with A in symmetric band storage */ +static void test_ssbmv(int n) { + int k = band_width(n); + int ldab = k + 1; + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *ab = xmalloc((size_t)ldab * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + float beta = -0.3f; + + make_sband_f32(A, ab, n, k); + fill_f32(x, n, 61); + fill_f32(y, n, 65); + memcpy(yr, y, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 0, 0); + cblas_ssbmv(CblasColMajor, CblasLower, n, k, alpha, ab, ldab, x, 1, beta, y, + 1); + + expect_l2_f32("ssbmv", n, y, yr, n); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* stbmv: x := A*x with A the lower triangle of a band matrix */ +static void test_stbmv(int n) { + int k = band_width(n); + int ldab = k + 1; + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *ab = xmalloc((size_t)ldab * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float one = 1.0f; + float zero = 0.0f; + + make_sband_f32(A, ab, n, k); + zero_upper_f32(A, n); + fill_f32(x, n, 61); + memcpy(y, x, (size_t)n * sizeof(float)); + memset(yr, 0, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &one, &zero, 1, 0, 0); + cblas_stbmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, k, ab, + ldab, y, 1); + + expect_l2_f32("stbmv", n, y, yr, n); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* stbsv: solve A*y = A*x on the same triangular band */ +static void test_stbsv(int n) { + int k = band_width(n); + int ldab = k + 1; + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *ab = xmalloc((size_t)ldab * n * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float one = 1.0f; + float zero = 0.0f; + + make_sband_f32(A, ab, n, k); + zero_upper_f32(A, n); + fill_f32(x, n, 61); + memset(y, 0, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, y, &one, &zero, 1, 0, 0); + cblas_stbsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, k, ab, + ldab, y, 1); + + expect_l2_f32("stbsv", n, y, x, n); + + free(A); + free(ab); + free(x); + free(y); +} + +/* sspmv: y := alpha*A*x + beta*y with symmetric A in packed storage */ +static void test_sspmv(int n) { + int np = n * (n + 1) / 2; + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *ap = xmalloc((size_t)np * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + float beta = -0.3f; + + /* Pack the lower triangle, then mirror it so the dense reference sees the + * same symmetric matrix. */ + make_tri_f32(A, n, n, CblasLower, 0); + pack_lower_f32(ap, A, n); + symmetrize_f32(A, n); + + fill_f32(x, n, 61); + fill_f32(y, n, 66); + memcpy(yr, y, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 0, 0); + cblas_sspmv(CblasColMajor, CblasLower, n, alpha, ap, x, 1, beta, y, 1); + + expect_l2_f32("sspmv", n, y, yr, n); + + free(A); + free(ap); + free(x); + free(y); + free(yr); +} + +/* stpmv: x := A*x with A lower triangular in packed storage */ +static void test_stpmv(int n) { + int np = n * (n + 1) / 2; + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *ap = xmalloc((size_t)np * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float *yr = xmalloc((size_t)n * sizeof(float)); + float one = 1.0f; + float zero = 0.0f; + + make_tri_f32(A, n, n, CblasLower, 0); + pack_lower_f32(ap, A, n); + fill_f32(x, n, 61); + memcpy(y, x, (size_t)n * sizeof(float)); + memset(yr, 0, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, yr, &one, &zero, 1, 0, 0); + cblas_stpmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, ap, y, + 1); + + expect_l2_f32("stpmv", n, y, yr, n); + + free(A); + free(ap); + free(x); + free(y); + free(yr); +} + +/* stpsv: solve A*y = A*x on the same packed triangle */ +static void test_stpsv(int n) { + int np = n * (n + 1) / 2; + float *A = xmalloc((size_t)n * n * sizeof(float)); + float *ap = xmalloc((size_t)np * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float one = 1.0f; + float zero = 0.0f; + + make_tri_f32(A, n, n, CblasLower, 0); + pack_lower_f32(ap, A, n); + fill_f32(x, n, 61); + memset(y, 0, (size_t)n * sizeof(float)); + + ref_l2_mv(n, A, x, y, &one, &zero, 1, 0, 0); + cblas_stpsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, ap, y, + 1); + + expect_l2_f32("stpsv", n, y, x, n); + + free(A); + free(ap); + free(x); + free(y); +} + +/* sspr: packed A := alpha*x*x^T + A, starting from a zero A */ +static void test_sspr(int n) { + int np = n * (n + 1) / 2; + float *ap = xmalloc((size_t)np * sizeof(float)); + float *apr = xmalloc((size_t)np * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + + fill_f32(x, n, 61); + memset(ap, 0, (size_t)np * sizeof(float)); + + cblas_sspr(CblasColMajor, CblasLower, n, alpha, x, 1, ap); + ref_spr_f32(apr, x, n, alpha); + + expect_l2_f32("sspr", n, ap, apr, np); + + free(ap); + free(apr); + free(x); +} + +/* sspr2: packed A := alpha*(x*y^T + y*x^T) + A. + * A starts from the SPR update so this is checked as an accumulation. */ +static void test_sspr2(int n) { + int np = n * (n + 1) / 2; + float *ap = xmalloc((size_t)np * sizeof(float)); + float *apr = xmalloc((size_t)np * sizeof(float)); + float *x = xmalloc((size_t)n * sizeof(float)); + float *y = xmalloc((size_t)n * sizeof(float)); + float alpha = 0.8f; + + fill_f32(x, n, 61); + fill_f32(y, n, 67); + ref_spr_f32(apr, x, n, alpha); + memcpy(ap, apr, (size_t)np * sizeof(float)); + + cblas_sspr2(CblasColMajor, CblasLower, n, alpha, x, 1, y, 1, ap); + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) + apr[packed_lower(i, j, n)] += alpha * (x[i] * y[j] + y[i] * x[j]); + + expect_l2_f32("sspr2", n, ap, apr, np); + + free(ap); + free(apr); + free(x); + free(y); +} + +/* ------------------------------------------------------------------------- */ +/* Real double-precision matrix builders */ +/* ------------------------------------------------------------------------- */ + +/* Mirror the lower triangle of A into the strict upper one. */ +static void symmetrize_f64(double *A, int n) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) + A[i + j * n] = A[j + i * n]; +} + +/* A pseudo-random symmetric matrix. */ +static void make_sym_f64(double *A, int n, int seed) { + fill_f64(A, n * n, seed); + symmetrize_f64(A, n); +} + +/* Drop the strict upper triangle, keeping the lower triangular part. */ +static void zero_upper_f64(double *A, int n) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) + A[i + j * n] = 0.0; +} + +/* Copy the lower triangle of A into packed storage. */ +static void pack_lower_f64(double *ap, const double *A, int n) { + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) + ap[packed_lower(i, j, n)] = A[i + j * n]; +} + +/* A general band matrix, both dense (A) and in (kl=ku=k) band storage (ab). */ +static void make_gband_f64(double *A, double *ab, int n, int k) { + int ldab = 2 * k + 1; + + memset(A, 0, (size_t)n * n * sizeof(double)); + memset(ab, 0, (size_t)ldab * n * sizeof(double)); + for (int j = 0; j < n; j++) + for (int i = j - k; i <= j + k; i++) { + double v; + + if (i < 0 || i >= n) + continue; + v = 0.15 + 0.01 * (double)(i + 2 * j); + A[i + j * n] = v; + ab[k + i - j + j * ldab] = v; + } +} + +/* A symmetric band matrix, both dense (A) and in lower band storage (ab). */ +static void make_sband_f64(double *A, double *ab, int n, int k) { + int ldab = k + 1; + + memset(A, 0, (size_t)n * n * sizeof(double)); + memset(ab, 0, (size_t)ldab * n * sizeof(double)); + for (int j = 0; j < n; j++) + for (int i = j; i <= j + k && i < n; i++) { + double v = (i == j) ? 2.0 : 0.1 + 0.01 * (double)(i + j); + + A[i + j * n] = v; + A[j + i * n] = v; + ab[i - j + j * ldab] = v; + } +} + +/* Packed lower triangle of alpha*x*x^T, the SPR reference. */ +static void ref_spr_f64(double *ap, const double *x, int n, double alpha) { + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) + ap[packed_lower(i, j, n)] = alpha * x[i] * x[j]; +} + +/* ------------------------------------------------------------------------- */ +/* Real double-precision Level-2 (compact grid) */ +/* ------------------------------------------------------------------------- */ + +/* dgemv: y := alpha*A*x + beta*y */ +static void test_dgemv_compact(int n) { + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + double beta = -0.3; + + make_sym_f64(A, n, 60); + fill_f64(x, n, 61); + fill_f64(y, n, 62); + memcpy(yr, y, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 1, 0); + cblas_dgemv(CblasColMajor, CblasNoTrans, n, n, alpha, A, n, x, 1, beta, y, 1); + + expect_l2_f64("dgemv", n, y, yr, n); + + free(A); + free(x); + free(y); + free(yr); +} + +/* dsymv: y := alpha*A*x + beta*y, symmetric A read from its lower triangle */ +static void test_dsymv(int n) { + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + double beta = -0.3; + + make_sym_f64(A, n, 60); + fill_f64(x, n, 61); + fill_f64(y, n, 63); + memcpy(yr, y, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 1, 0); + cblas_dsymv(CblasColMajor, CblasLower, n, alpha, A, n, x, 1, beta, y, 1); + + expect_l2_f64("dsymv", n, y, yr, n); + + free(A); + free(x); + free(y); + free(yr); +} + +/* dtrmv: x := A*x, A lower triangular with a non-unit diagonal */ +static void test_dtrmv(int n) { + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double one = 1.0; + double zero = 0.0; + + make_tri_f64(A, n, n, CblasLower, 0); + fill_f64(x, n, 61); + memcpy(y, x, (size_t)n * sizeof(double)); + memset(yr, 0, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &one, &zero, 1, 1, 0); + cblas_dtrmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, A, n, y, + 1); + + expect_l2_f64("dtrmv", n, y, yr, n); + + free(A); + free(x); + free(y); + free(yr); +} + +/* dtrsv: solve A*y = A*x on the same triangle, so y must come back as x */ +static void test_dtrsv(int n) { + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double one = 1.0; + double zero = 0.0; + + make_tri_f64(A, n, n, CblasLower, 0); + fill_f64(x, n, 61); + memset(y, 0, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, y, &one, &zero, 1, 1, 0); + cblas_dtrsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, A, n, y, + 1); + + expect_l2_f64("dtrsv", n, y, x, n); + + free(A); + free(x); + free(y); +} + +/* dtrmv: x := A^T*x, A upper triangular with an implicit unit diagonal */ +static void test_dtrmv_upper_unit(int n) { + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double one = 1.0; + double zero = 0.0; + + make_tri_f64(A, n, n, CblasUpper, 1); + fill_f64(x, n, 61); + memcpy(y, x, (size_t)n * sizeof(double)); + memset(yr, 0, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &one, &zero, 1, 1, 1); + cblas_dtrmv(CblasColMajor, CblasUpper, CblasTrans, CblasUnit, n, A, n, y, 1); + + expect_l2_f64("dtrmv-upper-unit", n, y, yr, n); + + free(A); + free(x); + free(y); + free(yr); +} + +/* dtrsv: solve A^T*y = A^T*x on the upper unit triangle */ +static void test_dtrsv_upper_unit(int n) { + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double one = 1.0; + double zero = 0.0; + + make_tri_f64(A, n, n, CblasUpper, 1); + fill_f64(x, n, 61); + memset(y, 0, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, y, &one, &zero, 1, 1, 1); + cblas_dtrsv(CblasColMajor, CblasUpper, CblasTrans, CblasUnit, n, A, n, y, 1); + + expect_l2_f64("dtrsv-upper-unit", n, y, x, n); + + free(A); + free(x); + free(y); +} + +/* dger: A := alpha*x*y^T + A, starting from a zero A */ +static void test_dger(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *Ar = xmalloc((size_t)nn * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + + fill_f64(x, n, 61); + fill_f64(y, n, 68); + memset(A, 0, (size_t)nn * sizeof(double)); + memset(Ar, 0, (size_t)nn * sizeof(double)); + + ref_l2_rank(n, Ar, x, y, &alpha, 1, 1, 0, 0, 0); + cblas_dger(CblasColMajor, n, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f64("dger", n, A, Ar, nn); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* dsyr: A := alpha*x*x^T + A, lower triangle only */ +static void test_dsyr(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *Ar = xmalloc((size_t)nn * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + + fill_f64(x, n, 61); + memset(A, 0, (size_t)nn * sizeof(double)); + memset(Ar, 0, (size_t)nn * sizeof(double)); + + ref_l2_rank(n, Ar, x, x, &alpha, 1, 1, 0, 1, 0); + cblas_dsyr(CblasColMajor, CblasLower, n, alpha, x, 1, A, n); + + expect_l2_f64("dsyr", n, A, Ar, nn); + + free(A); + free(Ar); + free(x); +} + +/* dsyr2: A := alpha*(x*y^T + y*x^T) + A, lower triangle only. + * A starts from a rank-1 update so the update is checked as an accumulation. */ +static void test_dsyr2(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *Ar = xmalloc((size_t)nn * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + + fill_f64(x, n, 61); + fill_f64(y, n, 68); + memset(Ar, 0, (size_t)nn * sizeof(double)); + ref_l2_rank(n, Ar, x, x, &alpha, 1, 1, 0, 1, 0); + memcpy(A, Ar, (size_t)nn * sizeof(double)); + + ref_l2_rank(n, Ar, x, y, &alpha, 1, 1, 0, 1, 0); + ref_l2_rank(n, Ar, y, x, &alpha, 1, 1, 0, 1, 0); + cblas_dsyr2(CblasColMajor, CblasLower, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f64("dsyr2", n, A, Ar, nn); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* dgbmv: y := alpha*A*x + beta*y with A in general band storage */ +static void test_dgbmv(int n) { + int k = band_width(n); + int ldab = 2 * k + 1; + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *ab = xmalloc((size_t)ldab * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + double beta = -0.3; + + make_gband_f64(A, ab, n, k); + fill_f64(x, n, 61); + fill_f64(y, n, 64); + memcpy(yr, y, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 1, 0); + cblas_dgbmv(CblasColMajor, CblasNoTrans, n, n, k, k, alpha, ab, ldab, x, 1, + beta, y, 1); + + expect_l2_f64("dgbmv", n, y, yr, n); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* dsbmv: y := alpha*A*x + beta*y with A in symmetric band storage */ +static void test_dsbmv(int n) { + int k = band_width(n); + int ldab = k + 1; + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *ab = xmalloc((size_t)ldab * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + double beta = -0.3; + + make_sband_f64(A, ab, n, k); + fill_f64(x, n, 61); + fill_f64(y, n, 65); + memcpy(yr, y, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 1, 0); + cblas_dsbmv(CblasColMajor, CblasLower, n, k, alpha, ab, ldab, x, 1, beta, y, + 1); + + expect_l2_f64("dsbmv", n, y, yr, n); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* dtbmv: x := A*x with A the lower triangle of a band matrix */ +static void test_dtbmv(int n) { + int k = band_width(n); + int ldab = k + 1; + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *ab = xmalloc((size_t)ldab * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double one = 1.0; + double zero = 0.0; + + make_sband_f64(A, ab, n, k); + zero_upper_f64(A, n); + fill_f64(x, n, 61); + memcpy(y, x, (size_t)n * sizeof(double)); + memset(yr, 0, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &one, &zero, 1, 1, 0); + cblas_dtbmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, k, ab, + ldab, y, 1); + + expect_l2_f64("dtbmv", n, y, yr, n); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* dtbsv: solve A*y = A*x on the same triangular band */ +static void test_dtbsv(int n) { + int k = band_width(n); + int ldab = k + 1; + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *ab = xmalloc((size_t)ldab * n * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double one = 1.0; + double zero = 0.0; + + make_sband_f64(A, ab, n, k); + zero_upper_f64(A, n); + fill_f64(x, n, 61); + memset(y, 0, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, y, &one, &zero, 1, 1, 0); + cblas_dtbsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, k, ab, + ldab, y, 1); + + expect_l2_f64("dtbsv", n, y, x, n); + + free(A); + free(ab); + free(x); + free(y); +} + +/* dspmv: y := alpha*A*x + beta*y with symmetric A in packed storage */ +static void test_dspmv(int n) { + int np = n * (n + 1) / 2; + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *ap = xmalloc((size_t)np * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + double beta = -0.3; + + make_tri_f64(A, n, n, CblasLower, 0); + pack_lower_f64(ap, A, n); + symmetrize_f64(A, n); + + fill_f64(x, n, 61); + fill_f64(y, n, 66); + memcpy(yr, y, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &alpha, &beta, 1, 1, 0); + cblas_dspmv(CblasColMajor, CblasLower, n, alpha, ap, x, 1, beta, y, 1); + + expect_l2_f64("dspmv", n, y, yr, n); + + free(A); + free(ap); + free(x); + free(y); + free(yr); +} + +/* dtpmv: x := A*x with A lower triangular in packed storage */ +static void test_dtpmv(int n) { + int np = n * (n + 1) / 2; + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *ap = xmalloc((size_t)np * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double *yr = xmalloc((size_t)n * sizeof(double)); + double one = 1.0; + double zero = 0.0; + + make_tri_f64(A, n, n, CblasLower, 0); + pack_lower_f64(ap, A, n); + fill_f64(x, n, 61); + memcpy(y, x, (size_t)n * sizeof(double)); + memset(yr, 0, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, yr, &one, &zero, 1, 1, 0); + cblas_dtpmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, ap, y, + 1); + + expect_l2_f64("dtpmv", n, y, yr, n); + + free(A); + free(ap); + free(x); + free(y); + free(yr); +} + +/* dtpsv: solve A*y = A*x on the same packed triangle */ +static void test_dtpsv(int n) { + int np = n * (n + 1) / 2; + double *A = xmalloc((size_t)n * n * sizeof(double)); + double *ap = xmalloc((size_t)np * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double one = 1.0; + double zero = 0.0; + + make_tri_f64(A, n, n, CblasLower, 0); + pack_lower_f64(ap, A, n); + fill_f64(x, n, 61); + memset(y, 0, (size_t)n * sizeof(double)); + + ref_l2_mv(n, A, x, y, &one, &zero, 1, 1, 0); + cblas_dtpsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, ap, y, + 1); + + expect_l2_f64("dtpsv", n, y, x, n); + + free(A); + free(ap); + free(x); + free(y); +} + +/* dspr: packed A := alpha*x*x^T + A, starting from a zero A */ +static void test_dspr(int n) { + int np = n * (n + 1) / 2; + double *ap = xmalloc((size_t)np * sizeof(double)); + double *apr = xmalloc((size_t)np * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + + fill_f64(x, n, 61); + memset(ap, 0, (size_t)np * sizeof(double)); + + cblas_dspr(CblasColMajor, CblasLower, n, alpha, x, 1, ap); + ref_spr_f64(apr, x, n, alpha); + + expect_l2_f64("dspr", n, ap, apr, np); + + free(ap); + free(apr); + free(x); +} + +/* dspr2: packed A := alpha*(x*y^T + y*x^T) + A. + * A starts from the SPR update so this is checked as an accumulation. */ +static void test_dspr2(int n) { + int np = n * (n + 1) / 2; + double *ap = xmalloc((size_t)np * sizeof(double)); + double *apr = xmalloc((size_t)np * sizeof(double)); + double *x = xmalloc((size_t)n * sizeof(double)); + double *y = xmalloc((size_t)n * sizeof(double)); + double alpha = 0.8; + + fill_f64(x, n, 61); + fill_f64(y, n, 67); + ref_spr_f64(apr, x, n, alpha); + memcpy(ap, apr, (size_t)np * sizeof(double)); + + cblas_dspr2(CblasColMajor, CblasLower, n, alpha, x, 1, y, 1, ap); + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) + apr[packed_lower(i, j, n)] += alpha * (x[i] * y[j] + y[i] * x[j]); + + expect_l2_f64("dspr2", n, ap, apr, np); + + free(ap); + free(apr); + free(x); + free(y); +} + +/* ------------------------------------------------------------------------- */ +/* Complex single-precision matrix builders */ +/* ------------------------------------------------------------------------- */ + +/* A triangular matrix with a real diagonal, well conditioned for TRSV. */ +static void make_tri_c32(float *A, int n, enum CBLAS_UPLO uplo, int unit) { + memset(A, 0, (size_t)2 * n * n * sizeof(float)); + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + int in_triangle = + (uplo == CblasLower && i >= j) || (uplo == CblasUpper && i <= j); + + if (!in_triangle) + continue; + A[2 * (i + j * n)] = i == j ? (unit ? 1.0f : 2.0f + 0.03f * (float)i) + : 0.08f * (float)(1 + (i + j) % 4); + A[2 * (i + j * n) + 1] = i == j ? 0.0f : 0.04f * (float)(i - j); + } +} + +/* Mirror the lower triangle of A into the strict upper one, conjugated. */ +static void hermitize_c32(float *A, int n) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) { + A[2 * (i + j * n)] = A[2 * (j + i * n)]; + A[2 * (i + j * n) + 1] = -A[2 * (j + i * n) + 1]; + } +} + +/* A pseudo-random Hermitian matrix (real diagonal, conjugate off-diagonal). */ +static void make_herm_c32(float *A, int n, int seed) { + fill_c32(A, n * n, seed); + for (int j = 0; j < n; j++) + A[2 * (j + j * n) + 1] = 0.0f; + hermitize_c32(A, n); +} + +/* Drop the strict upper triangle, keeping the lower triangular part. */ +static void zero_upper_c32(float *A, int n) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) { + A[2 * (i + j * n)] = 0.0f; + A[2 * (i + j * n) + 1] = 0.0f; + } +} + +/* Copy the lower triangle of A into packed storage. */ +static void pack_lower_c32(float *ap, const float *A, int n) { + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) { + int q = 2 * packed_lower(i, j, n); + + ap[q] = A[2 * (i + j * n)]; + ap[q + 1] = A[2 * (i + j * n) + 1]; + } +} + +/* A general band matrix, both dense (A) and in (kl=ku=k) band storage (ab). */ +static void make_gband_c32(float *A, float *ab, int n, int k) { + int ldab = 2 * k + 1; + + memset(A, 0, (size_t)2 * n * n * sizeof(float)); + memset(ab, 0, (size_t)2 * ldab * n * sizeof(float)); + for (int j = 0; j < n; j++) + for (int i = j - k; i <= j + k; i++) { + int ia; + int ib; + + if (i < 0 || i >= n) + continue; + ia = 2 * (i + j * n); + ib = 2 * (k + i - j + j * ldab); + A[ia] = 0.2f + 0.01f * (float)(i + j); + A[ia + 1] = 0.03f * (float)(i - j); + ab[ib] = A[ia]; + ab[ib + 1] = A[ia + 1]; + } +} + +/* A Hermitian band matrix, both dense (A) and in lower band storage (ab). + * The diagonal is real and equal to 2, so the lower triangle is safe to + * invert in TBSV. */ +static void make_hband_c32(float *A, float *ab, int n, int k) { + int ldab = k + 1; + + memset(A, 0, (size_t)2 * n * n * sizeof(float)); + memset(ab, 0, (size_t)2 * ldab * n * sizeof(float)); + for (int j = 0; j < n; j++) + for (int i = j; i <= j + k && i < n; i++) { + int ia = 2 * (i + j * n); + int it = 2 * (j + i * n); + int ib = 2 * (i - j + j * ldab); + + A[ia] = (i == j) ? 2.0f : 0.1f + 0.01f * (float)(i + j); + A[ia + 1] = (i == j) ? 0.0f : 0.03f * (float)(i - j); + A[it] = A[ia]; + A[it + 1] = -A[ia + 1]; + ab[ib] = A[ia]; + ab[ib + 1] = A[ia + 1]; + } +} + +/* Packed lower triangle of alpha*x*x^H, the HPR reference. The diagonal of a + * Hermitian rank update is real, so its imaginary part is forced to zero. */ +static void ref_hpr_c32(float *ap, const float *x, int n, float alpha) { + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) { + int q = 2 * packed_lower(i, j, n); + float xir = x[2 * i]; + float xii = x[2 * i + 1]; + float xjr = x[2 * j]; + float xji = x[2 * j + 1]; + + ap[q] = alpha * (xir * xjr + xii * xji); + ap[q + 1] = (i == j) ? 0.0f : alpha * (xii * xjr - xir * xji); + } +} + +/* ------------------------------------------------------------------------- */ +/* Complex single-precision Level-2 (compact grid) */ +/* ------------------------------------------------------------------------- */ + +/* cgemv: y := alpha*A*x + beta*y */ +static void test_cgemv(int n) { + int z = 2 * n; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + make_herm_c32(A, n, 70); + fill_c32(x, n, 71); + fill_c32(y, n, 72); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 0, 0); + cblas_cgemv(CblasColMajor, CblasNoTrans, n, n, alpha, A, n, x, 1, beta, y, 1); + + expect_l2_f32("cgemv", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* cgemv: y := alpha*A^H*x + beta*y */ +static void test_cgemv_conjtrans(int n) { + int z = 2 * n; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + make_herm_c32(A, n, 70); + fill_c32(x, n, 71); + fill_c32(y, n, 77); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 0, 1); + cblas_cgemv(CblasColMajor, CblasConjTrans, n, n, alpha, A, n, x, 1, beta, y, + 1); + + expect_l2_f32("cgemv-conjtrans", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* chemv: y := alpha*A*x + beta*y, Hermitian A read from its lower triangle */ +static void test_chemv(int n) { + int z = 2 * n; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + make_herm_c32(A, n, 70); + fill_c32(x, n, 71); + fill_c32(y, n, 73); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 0, 0); + cblas_chemv(CblasColMajor, CblasLower, n, alpha, A, n, x, 1, beta, y, 1); + + expect_l2_f32("chemv", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* ctrmv: x := A^H*x, A lower triangular with a non-unit diagonal */ +static void test_ctrmv(int n) { + int z = 2 * n; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + make_tri_c32(A, n, CblasLower, 0); + fill_c32(x, n, 71); + memcpy(y, x, (size_t)z * sizeof(float)); + memset(yr, 0, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, one, zero, 2, 0, 1); + cblas_ctrmv(CblasColMajor, CblasLower, CblasConjTrans, CblasNonUnit, n, A, n, + y, 1); + + expect_l2_f32("ctrmv", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* ctrsv: solve A^H*y = A^H*x on the same triangle */ +static void test_ctrsv(int n) { + int z = 2 * n; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + make_tri_c32(A, n, CblasLower, 0); + fill_c32(x, n, 71); + memset(y, 0, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, y, one, zero, 2, 0, 1); + cblas_ctrsv(CblasColMajor, CblasLower, CblasConjTrans, CblasNonUnit, n, A, n, + y, 1); + + expect_l2_f32("ctrsv", n, y, x, z); + + free(A); + free(x); + free(y); +} + +/* ctrmv: x := A^H*x, A upper triangular with an implicit unit diagonal */ +static void test_ctrmv_upper_unit(int n) { + int z = 2 * n; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + make_tri_c32(A, n, CblasUpper, 1); + fill_c32(x, n, 71); + memcpy(y, x, (size_t)z * sizeof(float)); + memset(yr, 0, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, one, zero, 2, 0, 1); + cblas_ctrmv(CblasColMajor, CblasUpper, CblasConjTrans, CblasUnit, n, A, n, y, + 1); + + expect_l2_f32("ctrmv-upper-unit", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* ctrsv: solve A^H*y = A^H*x on the upper unit triangle */ +static void test_ctrsv_upper_unit(int n) { + int z = 2 * n; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + make_tri_c32(A, n, CblasUpper, 1); + fill_c32(x, n, 71); + memset(y, 0, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, y, one, zero, 2, 0, 1); + cblas_ctrsv(CblasColMajor, CblasUpper, CblasConjTrans, CblasUnit, n, A, n, y, + 1); + + expect_l2_f32("ctrsv-upper-unit", n, y, x, z); + + free(A); + free(x); + free(y); +} + +/* cgeru: A := alpha*x*y^T + A, starting from a zero A */ +static void test_cgeru(int n) { + int nz = 2 * n * n; + float *A = xmalloc((size_t)nz * sizeof(float)); + float *Ar = xmalloc((size_t)nz * sizeof(float)); + float *x = xmalloc((size_t)2 * n * sizeof(float)); + float *y = xmalloc((size_t)2 * n * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + + fill_c32(x, n, 71); + fill_c32(y, n, 78); + memset(A, 0, (size_t)nz * sizeof(float)); + memset(Ar, 0, (size_t)nz * sizeof(float)); + + ref_l2_rank(n, Ar, x, y, alpha, 2, 0, 0, 0, 0); + cblas_cgeru(CblasColMajor, n, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f32("cgeru", n, A, Ar, nz); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* cgerc: A := alpha*x*y^H + A, starting from a zero A */ +static void test_cgerc(int n) { + int nz = 2 * n * n; + float *A = xmalloc((size_t)nz * sizeof(float)); + float *Ar = xmalloc((size_t)nz * sizeof(float)); + float *x = xmalloc((size_t)2 * n * sizeof(float)); + float *y = xmalloc((size_t)2 * n * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + + fill_c32(x, n, 71); + fill_c32(y, n, 78); + memset(A, 0, (size_t)nz * sizeof(float)); + memset(Ar, 0, (size_t)nz * sizeof(float)); + + ref_l2_rank(n, Ar, x, y, alpha, 2, 0, 1, 0, 0); + cblas_cgerc(CblasColMajor, n, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f32("cgerc", n, A, Ar, nz); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* cher: A := alpha*x*x^H + A with a real alpha, lower triangle only */ +static void test_cher(int n) { + int nz = 2 * n * n; + float *A = xmalloc((size_t)nz * sizeof(float)); + float *Ar = xmalloc((size_t)nz * sizeof(float)); + float *x = xmalloc((size_t)2 * n * sizeof(float)); + float alpha = 0.6f; + float alpha_c[2] = {0.6f, 0.0f}; + + fill_c32(x, n, 71); + memset(A, 0, (size_t)nz * sizeof(float)); + memset(Ar, 0, (size_t)nz * sizeof(float)); + + ref_l2_rank(n, Ar, x, x, alpha_c, 2, 0, 1, 1, 1); + cblas_cher(CblasColMajor, CblasLower, n, alpha, x, 1, A, n); + + expect_l2_f32("cher", n, A, Ar, nz); + + free(A); + free(Ar); + free(x); +} + +/* cher2: A := alpha*x*y^H + conj(alpha)*y*x^H + A, lower triangle only. + * A starts from a Hermitian rank-1 update so this is checked as an + * accumulation. Note the second term carries the conjugate of alpha. */ +static void test_cher2(int n) { + int nz = 2 * n * n; + float *A = xmalloc((size_t)nz * sizeof(float)); + float *Ar = xmalloc((size_t)nz * sizeof(float)); + float *x = xmalloc((size_t)2 * n * sizeof(float)); + float *y = xmalloc((size_t)2 * n * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float alpha_conj[2] = {0.8f, 0.2f}; + float base[2] = {0.6f, 0.0f}; + + fill_c32(x, n, 71); + fill_c32(y, n, 78); + memset(Ar, 0, (size_t)nz * sizeof(float)); + ref_l2_rank(n, Ar, x, x, base, 2, 0, 1, 1, 1); + memcpy(A, Ar, (size_t)nz * sizeof(float)); + + ref_l2_rank(n, Ar, x, y, alpha, 2, 0, 1, 1, 1); + ref_l2_rank(n, Ar, y, x, alpha_conj, 2, 0, 1, 1, 1); + cblas_cher2(CblasColMajor, CblasLower, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f32("cher2", n, A, Ar, nz); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* cgbmv: y := alpha*A*x + beta*y with A in general band storage */ +static void test_cgbmv(int n) { + int z = 2 * n; + int k = band_width(n); + int ldab = 2 * k + 1; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *ab = xmalloc((size_t)2 * ldab * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + make_gband_c32(A, ab, n, k); + fill_c32(x, n, 71); + fill_c32(y, n, 74); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 0, 0); + cblas_cgbmv(CblasColMajor, CblasNoTrans, n, n, k, k, alpha, ab, ldab, x, 1, + beta, y, 1); + + expect_l2_f32("cgbmv", n, y, yr, z); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* chbmv: y := alpha*A*x + beta*y with A in Hermitian band storage */ +static void test_chbmv(int n) { + int z = 2 * n; + int k = band_width(n); + int ldab = k + 1; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *ab = xmalloc((size_t)2 * ldab * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + make_hband_c32(A, ab, n, k); + fill_c32(x, n, 71); + fill_c32(y, n, 75); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 0, 0); + cblas_chbmv(CblasColMajor, CblasLower, n, k, alpha, ab, ldab, x, 1, beta, y, + 1); + + expect_l2_f32("chbmv", n, y, yr, z); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* ctbmv: x := A*x with A the lower triangle of a band matrix */ +static void test_ctbmv(int n) { + int z = 2 * n; + int k = band_width(n); + int ldab = k + 1; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *ab = xmalloc((size_t)2 * ldab * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + make_hband_c32(A, ab, n, k); + zero_upper_c32(A, n); + fill_c32(x, n, 71); + memcpy(y, x, (size_t)z * sizeof(float)); + memset(yr, 0, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, one, zero, 2, 0, 0); + cblas_ctbmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, k, ab, + ldab, y, 1); + + expect_l2_f32("ctbmv", n, y, yr, z); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* ctbsv: solve A*y = A*x on the same triangular band */ +static void test_ctbsv(int n) { + int z = 2 * n; + int k = band_width(n); + int ldab = k + 1; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *ab = xmalloc((size_t)2 * ldab * n * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + make_hband_c32(A, ab, n, k); + zero_upper_c32(A, n); + fill_c32(x, n, 71); + memset(y, 0, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, y, one, zero, 2, 0, 0); + cblas_ctbsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, k, ab, + ldab, y, 1); + + expect_l2_f32("ctbsv", n, y, x, z); + + free(A); + free(ab); + free(x); + free(y); +} + +/* chpmv: y := alpha*A*x + beta*y with Hermitian A in packed storage */ +static void test_chpmv(int n) { + int z = 2 * n; + int np = n * (n + 1) / 2; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *ap = xmalloc((size_t)2 * np * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + /* Pack the lower triangle, then mirror it conjugated so the dense reference + * sees the same Hermitian matrix. */ + make_tri_c32(A, n, CblasLower, 0); + pack_lower_c32(ap, A, n); + hermitize_c32(A, n); + + fill_c32(x, n, 71); + fill_c32(y, n, 76); + memcpy(yr, y, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 0, 0); + cblas_chpmv(CblasColMajor, CblasLower, n, alpha, ap, x, 1, beta, y, 1); + + expect_l2_f32("chpmv", n, y, yr, z); + + free(A); + free(ap); + free(x); + free(y); + free(yr); +} + +/* ctpmv: x := A*x with A lower triangular in packed storage */ +static void test_ctpmv(int n) { + int z = 2 * n; + int np = n * (n + 1) / 2; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *ap = xmalloc((size_t)2 * np * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float *yr = xmalloc((size_t)z * sizeof(float)); + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + make_tri_c32(A, n, CblasLower, 0); + pack_lower_c32(ap, A, n); + fill_c32(x, n, 71); + memcpy(y, x, (size_t)z * sizeof(float)); + memset(yr, 0, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, yr, one, zero, 2, 0, 0); + cblas_ctpmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, ap, y, + 1); + + expect_l2_f32("ctpmv", n, y, yr, z); + + free(A); + free(ap); + free(x); + free(y); + free(yr); +} + +/* ctpsv: solve A*y = A*x on the same packed triangle */ +static void test_ctpsv(int n) { + int z = 2 * n; + int np = n * (n + 1) / 2; + float *A = xmalloc((size_t)2 * n * n * sizeof(float)); + float *ap = xmalloc((size_t)2 * np * sizeof(float)); + float *x = xmalloc((size_t)z * sizeof(float)); + float *y = xmalloc((size_t)z * sizeof(float)); + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + make_tri_c32(A, n, CblasLower, 0); + pack_lower_c32(ap, A, n); + fill_c32(x, n, 71); + memset(y, 0, (size_t)z * sizeof(float)); + + ref_l2_mv(n, A, x, y, one, zero, 2, 0, 0); + cblas_ctpsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, ap, y, + 1); + + expect_l2_f32("ctpsv", n, y, x, z); + + free(A); + free(ap); + free(x); + free(y); +} + +/* chpr: packed A := alpha*x*x^H + A with a real alpha, from a zero A */ +static void test_chpr(int n) { + int np = n * (n + 1) / 2; + float *ap = xmalloc((size_t)2 * np * sizeof(float)); + float *apr = xmalloc((size_t)2 * np * sizeof(float)); + float *x = xmalloc((size_t)2 * n * sizeof(float)); + float alpha = 0.6f; + + fill_c32(x, n, 71); + memset(ap, 0, (size_t)2 * np * sizeof(float)); + + cblas_chpr(CblasColMajor, CblasLower, n, alpha, x, 1, ap); + ref_hpr_c32(apr, x, n, alpha); + + expect_l2_f32("chpr", n, ap, apr, 2 * np); + + free(ap); + free(apr); + free(x); +} + +/* chpr2: packed A := alpha*x*y^H + conj(alpha)*y*x^H + A. + * A starts from the HPR update so this is checked as an accumulation. */ +static void test_chpr2(int n) { + int np = n * (n + 1) / 2; + float *ap = xmalloc((size_t)2 * np * sizeof(float)); + float *apr = xmalloc((size_t)2 * np * sizeof(float)); + float *x = xmalloc((size_t)2 * n * sizeof(float)); + float *y = xmalloc((size_t)2 * n * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + + fill_c32(x, n, 71); + fill_c32(y, n, 79); + ref_hpr_c32(apr, x, n, 0.6f); + memcpy(ap, apr, (size_t)2 * np * sizeof(float)); + + cblas_chpr2(CblasColMajor, CblasLower, n, alpha, x, 1, y, 1, ap); + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) { + int q = 2 * packed_lower(i, j, n); + /* p1 = x_i * conj(y_j) and p2 = y_i * conj(x_j) */ + float p1r = x[2 * i] * y[2 * j] + x[2 * i + 1] * y[2 * j + 1]; + float p1i = x[2 * i + 1] * y[2 * j] - x[2 * i] * y[2 * j + 1]; + float p2r = y[2 * i] * x[2 * j] + y[2 * i + 1] * x[2 * j + 1]; + float p2i = y[2 * i + 1] * x[2 * j] - y[2 * i] * x[2 * j + 1]; + + /* alpha*p1 + conj(alpha)*p2; the diagonal stays real. */ + apr[q] += + alpha[0] * p1r - alpha[1] * p1i + alpha[0] * p2r + alpha[1] * p2i; + apr[q + 1] = (i == j) ? 0.0f + : apr[q + 1] + alpha[0] * p1i + alpha[1] * p1r + + alpha[0] * p2i - alpha[1] * p2r; + } + + expect_l2_f32("chpr2", n, ap, apr, 2 * np); + + free(ap); + free(apr); + free(x); + free(y); +} + +/* ------------------------------------------------------------------------- */ +/* Complex double-precision matrix builders */ +/* ------------------------------------------------------------------------- */ + +/* A triangular matrix with a real diagonal, well conditioned for TRSV. */ +static void make_tri_c64(double *A, int n, enum CBLAS_UPLO uplo, int unit) { + memset(A, 0, (size_t)2 * n * n * sizeof(double)); + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + int in_triangle = + (uplo == CblasLower && i >= j) || (uplo == CblasUpper && i <= j); + + if (!in_triangle) + continue; + A[2 * (i + j * n)] = i == j ? (unit ? 1.0 : 2.0 + 0.03 * (double)i) + : 0.08 * (double)(1 + (i + j) % 4); + A[2 * (i + j * n) + 1] = i == j ? 0.0 : 0.04 * (double)(i - j); + } +} + +/* Mirror the lower triangle of A into the strict upper one, conjugated. */ +static void hermitize_c64(double *A, int n) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) { + A[2 * (i + j * n)] = A[2 * (j + i * n)]; + A[2 * (i + j * n) + 1] = -A[2 * (j + i * n) + 1]; + } +} + +/* A pseudo-random Hermitian matrix (real diagonal, conjugate off-diagonal). */ +static void make_herm_c64(double *A, int n, int seed) { + fill_c64(A, n * n, seed); + for (int j = 0; j < n; j++) + A[2 * (j + j * n) + 1] = 0.0; + hermitize_c64(A, n); +} + +/* Drop the strict upper triangle, keeping the lower triangular part. */ +static void zero_upper_c64(double *A, int n) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) { + A[2 * (i + j * n)] = 0.0; + A[2 * (i + j * n) + 1] = 0.0; + } +} + +/* Copy the lower triangle of A into packed storage. */ +static void pack_lower_c64(double *ap, const double *A, int n) { + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) { + int q = 2 * packed_lower(i, j, n); + + ap[q] = A[2 * (i + j * n)]; + ap[q + 1] = A[2 * (i + j * n) + 1]; + } +} + +/* A general band matrix, both dense (A) and in (kl=ku=k) band storage (ab). */ +static void make_gband_c64(double *A, double *ab, int n, int k) { + int ldab = 2 * k + 1; + + memset(A, 0, (size_t)2 * n * n * sizeof(double)); + memset(ab, 0, (size_t)2 * ldab * n * sizeof(double)); + for (int j = 0; j < n; j++) + for (int i = j - k; i <= j + k; i++) { + int ia; + int ib; + + if (i < 0 || i >= n) + continue; + ia = 2 * (i + j * n); + ib = 2 * (k + i - j + j * ldab); + A[ia] = 0.2 + 0.01 * (double)(i + j); + A[ia + 1] = 0.03 * (double)(i - j); + ab[ib] = A[ia]; + ab[ib + 1] = A[ia + 1]; + } +} + +/* A Hermitian band matrix, both dense (A) and in lower band storage (ab). */ +static void make_hband_c64(double *A, double *ab, int n, int k) { + int ldab = k + 1; + + memset(A, 0, (size_t)2 * n * n * sizeof(double)); + memset(ab, 0, (size_t)2 * ldab * n * sizeof(double)); + for (int j = 0; j < n; j++) + for (int i = j; i <= j + k && i < n; i++) { + int ia = 2 * (i + j * n); + int it = 2 * (j + i * n); + int ib = 2 * (i - j + j * ldab); + + A[ia] = (i == j) ? 2.0 : 0.1 + 0.01 * (double)(i + j); + A[ia + 1] = (i == j) ? 0.0 : 0.03 * (double)(i - j); + A[it] = A[ia]; + A[it + 1] = -A[ia + 1]; + ab[ib] = A[ia]; + ab[ib + 1] = A[ia + 1]; + } +} + +/* Packed lower triangle of alpha*x*x^H, the HPR reference. */ +static void ref_hpr_c64(double *ap, const double *x, int n, double alpha) { + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) { + int q = 2 * packed_lower(i, j, n); + double xir = x[2 * i]; + double xii = x[2 * i + 1]; + double xjr = x[2 * j]; + double xji = x[2 * j + 1]; + + ap[q] = alpha * (xir * xjr + xii * xji); + ap[q + 1] = (i == j) ? 0.0 : alpha * (xii * xjr - xir * xji); + } +} + +/* ------------------------------------------------------------------------- */ +/* Complex double-precision Level-2 (compact grid) */ +/* ------------------------------------------------------------------------- */ + +/* zgemv: y := alpha*A*x + beta*y */ +static void test_zgemv(int n) { + int z = 2 * n; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + make_herm_c64(A, n, 70); + fill_c64(x, n, 71); + fill_c64(y, n, 72); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 1, 0); + cblas_zgemv(CblasColMajor, CblasNoTrans, n, n, alpha, A, n, x, 1, beta, y, 1); + + expect_l2_f64("zgemv", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* zgemv: y := alpha*A^H*x + beta*y */ +static void test_zgemv_conjtrans(int n) { + int z = 2 * n; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + make_herm_c64(A, n, 70); + fill_c64(x, n, 71); + fill_c64(y, n, 77); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 1, 1); + cblas_zgemv(CblasColMajor, CblasConjTrans, n, n, alpha, A, n, x, 1, beta, y, + 1); + + expect_l2_f64("zgemv-conjtrans", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* zhemv: y := alpha*A*x + beta*y, Hermitian A read from its lower triangle */ +static void test_zhemv(int n) { + int z = 2 * n; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + make_herm_c64(A, n, 70); + fill_c64(x, n, 71); + fill_c64(y, n, 73); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 1, 0); + cblas_zhemv(CblasColMajor, CblasLower, n, alpha, A, n, x, 1, beta, y, 1); + + expect_l2_f64("zhemv", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* ztrmv: x := A^H*x, A lower triangular with a non-unit diagonal */ +static void test_ztrmv(int n) { + int z = 2 * n; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + make_tri_c64(A, n, CblasLower, 0); + fill_c64(x, n, 71); + memcpy(y, x, (size_t)z * sizeof(double)); + memset(yr, 0, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, one, zero, 2, 1, 1); + cblas_ztrmv(CblasColMajor, CblasLower, CblasConjTrans, CblasNonUnit, n, A, n, + y, 1); + + expect_l2_f64("ztrmv", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* ztrsv: solve A^H*y = A^H*x on the same triangle */ +static void test_ztrsv(int n) { + int z = 2 * n; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + make_tri_c64(A, n, CblasLower, 0); + fill_c64(x, n, 71); + memset(y, 0, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, y, one, zero, 2, 1, 1); + cblas_ztrsv(CblasColMajor, CblasLower, CblasConjTrans, CblasNonUnit, n, A, n, + y, 1); + + expect_l2_f64("ztrsv", n, y, x, z); + + free(A); + free(x); + free(y); +} + +/* ztrmv: x := A^H*x, A upper triangular with an implicit unit diagonal */ +static void test_ztrmv_upper_unit(int n) { + int z = 2 * n; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + make_tri_c64(A, n, CblasUpper, 1); + fill_c64(x, n, 71); + memcpy(y, x, (size_t)z * sizeof(double)); + memset(yr, 0, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, one, zero, 2, 1, 1); + cblas_ztrmv(CblasColMajor, CblasUpper, CblasConjTrans, CblasUnit, n, A, n, y, + 1); + + expect_l2_f64("ztrmv-upper-unit", n, y, yr, z); + + free(A); + free(x); + free(y); + free(yr); +} + +/* ztrsv: solve A^H*y = A^H*x on the upper unit triangle */ +static void test_ztrsv_upper_unit(int n) { + int z = 2 * n; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + make_tri_c64(A, n, CblasUpper, 1); + fill_c64(x, n, 71); + memset(y, 0, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, y, one, zero, 2, 1, 1); + cblas_ztrsv(CblasColMajor, CblasUpper, CblasConjTrans, CblasUnit, n, A, n, y, + 1); + + expect_l2_f64("ztrsv-upper-unit", n, y, x, z); + + free(A); + free(x); + free(y); +} + +/* zgeru: A := alpha*x*y^T + A, starting from a zero A */ +static void test_zgeru(int n) { + int nz = 2 * n * n; + double *A = xmalloc((size_t)nz * sizeof(double)); + double *Ar = xmalloc((size_t)nz * sizeof(double)); + double *x = xmalloc((size_t)2 * n * sizeof(double)); + double *y = xmalloc((size_t)2 * n * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + + fill_c64(x, n, 71); + fill_c64(y, n, 78); + memset(A, 0, (size_t)nz * sizeof(double)); + memset(Ar, 0, (size_t)nz * sizeof(double)); + + ref_l2_rank(n, Ar, x, y, alpha, 2, 1, 0, 0, 0); + cblas_zgeru(CblasColMajor, n, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f64("zgeru", n, A, Ar, nz); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* zgerc: A := alpha*x*y^H + A, starting from a zero A */ +static void test_zgerc(int n) { + int nz = 2 * n * n; + double *A = xmalloc((size_t)nz * sizeof(double)); + double *Ar = xmalloc((size_t)nz * sizeof(double)); + double *x = xmalloc((size_t)2 * n * sizeof(double)); + double *y = xmalloc((size_t)2 * n * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + + fill_c64(x, n, 71); + fill_c64(y, n, 78); + memset(A, 0, (size_t)nz * sizeof(double)); + memset(Ar, 0, (size_t)nz * sizeof(double)); + + ref_l2_rank(n, Ar, x, y, alpha, 2, 1, 1, 0, 0); + cblas_zgerc(CblasColMajor, n, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f64("zgerc", n, A, Ar, nz); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* zher: A := alpha*x*x^H + A with a real alpha, lower triangle only */ +static void test_zher(int n) { + int nz = 2 * n * n; + double *A = xmalloc((size_t)nz * sizeof(double)); + double *Ar = xmalloc((size_t)nz * sizeof(double)); + double *x = xmalloc((size_t)2 * n * sizeof(double)); + double alpha = 0.6; + double alpha_c[2] = {0.6, 0.0}; + + fill_c64(x, n, 71); + memset(A, 0, (size_t)nz * sizeof(double)); + memset(Ar, 0, (size_t)nz * sizeof(double)); + + ref_l2_rank(n, Ar, x, x, alpha_c, 2, 1, 1, 1, 1); + cblas_zher(CblasColMajor, CblasLower, n, alpha, x, 1, A, n); + + expect_l2_f64("zher", n, A, Ar, nz); + + free(A); + free(Ar); + free(x); +} + +/* zher2: A := alpha*x*y^H + conj(alpha)*y*x^H + A, lower triangle only. + * A starts from a Hermitian rank-1 update so this is checked as an + * accumulation. Note the second term carries the conjugate of alpha. */ +static void test_zher2(int n) { + int nz = 2 * n * n; + double *A = xmalloc((size_t)nz * sizeof(double)); + double *Ar = xmalloc((size_t)nz * sizeof(double)); + double *x = xmalloc((size_t)2 * n * sizeof(double)); + double *y = xmalloc((size_t)2 * n * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double alpha_conj[2] = {0.8, 0.2}; + double base[2] = {0.6, 0.0}; + + fill_c64(x, n, 71); + fill_c64(y, n, 78); + memset(Ar, 0, (size_t)nz * sizeof(double)); + ref_l2_rank(n, Ar, x, x, base, 2, 1, 1, 1, 1); + memcpy(A, Ar, (size_t)nz * sizeof(double)); + + ref_l2_rank(n, Ar, x, y, alpha, 2, 1, 1, 1, 1); + ref_l2_rank(n, Ar, y, x, alpha_conj, 2, 1, 1, 1, 1); + cblas_zher2(CblasColMajor, CblasLower, n, alpha, x, 1, y, 1, A, n); + + expect_l2_f64("zher2", n, A, Ar, nz); + + free(A); + free(Ar); + free(x); + free(y); +} + +/* zgbmv: y := alpha*A*x + beta*y with A in general band storage */ +static void test_zgbmv(int n) { + int z = 2 * n; + int k = band_width(n); + int ldab = 2 * k + 1; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *ab = xmalloc((size_t)2 * ldab * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + make_gband_c64(A, ab, n, k); + fill_c64(x, n, 71); + fill_c64(y, n, 74); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 1, 0); + cblas_zgbmv(CblasColMajor, CblasNoTrans, n, n, k, k, alpha, ab, ldab, x, 1, + beta, y, 1); + + expect_l2_f64("zgbmv", n, y, yr, z); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* zhbmv: y := alpha*A*x + beta*y with A in Hermitian band storage */ +static void test_zhbmv(int n) { + int z = 2 * n; + int k = band_width(n); + int ldab = k + 1; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *ab = xmalloc((size_t)2 * ldab * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + make_hband_c64(A, ab, n, k); + fill_c64(x, n, 71); + fill_c64(y, n, 75); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 1, 0); + cblas_zhbmv(CblasColMajor, CblasLower, n, k, alpha, ab, ldab, x, 1, beta, y, + 1); + + expect_l2_f64("zhbmv", n, y, yr, z); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* ztbmv: x := A*x with A the lower triangle of a band matrix */ +static void test_ztbmv(int n) { + int z = 2 * n; + int k = band_width(n); + int ldab = k + 1; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *ab = xmalloc((size_t)2 * ldab * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + make_hband_c64(A, ab, n, k); + zero_upper_c64(A, n); + fill_c64(x, n, 71); + memcpy(y, x, (size_t)z * sizeof(double)); + memset(yr, 0, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, one, zero, 2, 1, 0); + cblas_ztbmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, k, ab, + ldab, y, 1); + + expect_l2_f64("ztbmv", n, y, yr, z); + + free(A); + free(ab); + free(x); + free(y); + free(yr); +} + +/* ztbsv: solve A*y = A*x on the same triangular band */ +static void test_ztbsv(int n) { + int z = 2 * n; + int k = band_width(n); + int ldab = k + 1; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *ab = xmalloc((size_t)2 * ldab * n * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + make_hband_c64(A, ab, n, k); + zero_upper_c64(A, n); + fill_c64(x, n, 71); + memset(y, 0, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, y, one, zero, 2, 1, 0); + cblas_ztbsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, k, ab, + ldab, y, 1); + + expect_l2_f64("ztbsv", n, y, x, z); + + free(A); + free(ab); + free(x); + free(y); +} + +/* zhpmv: y := alpha*A*x + beta*y with Hermitian A in packed storage */ +static void test_zhpmv(int n) { + int z = 2 * n; + int np = n * (n + 1) / 2; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *ap = xmalloc((size_t)2 * np * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + make_tri_c64(A, n, CblasLower, 0); + pack_lower_c64(ap, A, n); + hermitize_c64(A, n); + + fill_c64(x, n, 71); + fill_c64(y, n, 76); + memcpy(yr, y, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, alpha, beta, 2, 1, 0); + cblas_zhpmv(CblasColMajor, CblasLower, n, alpha, ap, x, 1, beta, y, 1); + + expect_l2_f64("zhpmv", n, y, yr, z); + + free(A); + free(ap); + free(x); + free(y); + free(yr); +} + +/* ztpmv: x := A*x with A lower triangular in packed storage */ +static void test_ztpmv(int n) { + int z = 2 * n; + int np = n * (n + 1) / 2; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *ap = xmalloc((size_t)2 * np * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double *yr = xmalloc((size_t)z * sizeof(double)); + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + make_tri_c64(A, n, CblasLower, 0); + pack_lower_c64(ap, A, n); + fill_c64(x, n, 71); + memcpy(y, x, (size_t)z * sizeof(double)); + memset(yr, 0, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, yr, one, zero, 2, 1, 0); + cblas_ztpmv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, ap, y, + 1); + + expect_l2_f64("ztpmv", n, y, yr, z); + + free(A); + free(ap); + free(x); + free(y); + free(yr); +} + +/* ztpsv: solve A*y = A*x on the same packed triangle */ +static void test_ztpsv(int n) { + int z = 2 * n; + int np = n * (n + 1) / 2; + double *A = xmalloc((size_t)2 * n * n * sizeof(double)); + double *ap = xmalloc((size_t)2 * np * sizeof(double)); + double *x = xmalloc((size_t)z * sizeof(double)); + double *y = xmalloc((size_t)z * sizeof(double)); + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + make_tri_c64(A, n, CblasLower, 0); + pack_lower_c64(ap, A, n); + fill_c64(x, n, 71); + memset(y, 0, (size_t)z * sizeof(double)); + + ref_l2_mv(n, A, x, y, one, zero, 2, 1, 0); + cblas_ztpsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, n, ap, y, + 1); + + expect_l2_f64("ztpsv", n, y, x, z); + + free(A); + free(ap); + free(x); + free(y); +} + +/* zhpr: packed A := alpha*x*x^H + A with a real alpha, from a zero A */ +static void test_zhpr(int n) { + int np = n * (n + 1) / 2; + double *ap = xmalloc((size_t)2 * np * sizeof(double)); + double *apr = xmalloc((size_t)2 * np * sizeof(double)); + double *x = xmalloc((size_t)2 * n * sizeof(double)); + double alpha = 0.6; + + fill_c64(x, n, 71); + memset(ap, 0, (size_t)2 * np * sizeof(double)); + + cblas_zhpr(CblasColMajor, CblasLower, n, alpha, x, 1, ap); + ref_hpr_c64(apr, x, n, alpha); + + expect_l2_f64("zhpr", n, ap, apr, 2 * np); + + free(ap); + free(apr); + free(x); +} + +/* zhpr2: packed A := alpha*x*y^H + conj(alpha)*y*x^H + A. + * A starts from the HPR update so this is checked as an accumulation. */ +static void test_zhpr2(int n) { + int np = n * (n + 1) / 2; + double *ap = xmalloc((size_t)2 * np * sizeof(double)); + double *apr = xmalloc((size_t)2 * np * sizeof(double)); + double *x = xmalloc((size_t)2 * n * sizeof(double)); + double *y = xmalloc((size_t)2 * n * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + + fill_c64(x, n, 71); + fill_c64(y, n, 79); + ref_hpr_c64(apr, x, n, 0.6); + memcpy(ap, apr, (size_t)2 * np * sizeof(double)); + + cblas_zhpr2(CblasColMajor, CblasLower, n, alpha, x, 1, y, 1, ap); + for (int j = 0; j < n; j++) + for (int i = j; i < n; i++) { + int q = 2 * packed_lower(i, j, n); + /* p1 = x_i * conj(y_j) and p2 = y_i * conj(x_j) */ + double p1r = x[2 * i] * y[2 * j] + x[2 * i + 1] * y[2 * j + 1]; + double p1i = x[2 * i + 1] * y[2 * j] - x[2 * i] * y[2 * j + 1]; + double p2r = y[2 * i] * x[2 * j] + y[2 * i + 1] * x[2 * j + 1]; + double p2i = y[2 * i + 1] * x[2 * j] - y[2 * i] * x[2 * j + 1]; + + /* alpha*p1 + conj(alpha)*p2; the diagonal stays real. */ + apr[q] += + alpha[0] * p1r - alpha[1] * p1i + alpha[0] * p2r + alpha[1] * p2i; + apr[q + 1] = (i == j) ? 0.0 + : apr[q + 1] + alpha[0] * p1i + alpha[1] * p1r + + alpha[0] * p2i - alpha[1] * p2r; + } + + expect_l2_f64("zhpr2", n, ap, apr, 2 * np); + + free(ap); + free(apr); + free(x); + free(y); +} + +/* ------------------------------------------------------------------------- */ +/* Drivers */ +/* ------------------------------------------------------------------------- */ + +static void run_deep_gemv(void) { + printf("==> L2 GEMV (deep shape / stride grid)\n"); + enum CBLAS_TRANSPOSE tr[2] = {CblasNoTrans, CblasTrans}; + + for (int s = 0; s < NS_L2; s++) { + int n = SIZES_L2[s]; + use_fill_case(s); + /* Square and a few rectangular shapes. */ + int ms[3] = {n, n + (n > 1 ? 1 : 0), n > 2 ? n - 1 : n}; + int ns[3] = {n, n > 2 ? n - 1 : n, n + (n > 1 ? 2 : 0)}; + + for (int t = 0; t < 2; t++) { + for (int k = 0; k < 3; k++) { + int m = ms[k]; + int nn = ns[k]; + + if (m < 1 || nn < 1) + continue; + + test_sgemv(tr[t], m, nn, 1, 1); + test_dgemv(tr[t], m, nn, 1, 1); + + if (n <= 36) { + test_sgemv(tr[t], m, nn, 2, 3); + test_dgemv(tr[t], m, nn, 2, 3); + } + } + } + } +} + +static void run_compact_l2(void) { + printf("==> L2 dense, banded, and packed S/D/C/Z families\n"); + + for (int i = 0; i < NS_FULL; i++) { + int n = SIZES_FULL[i]; + use_fill_case(i); + + test_sgemv_compact(n); + test_ssymv(n); + test_strmv(n); + test_strsv(n); + test_strmv_upper_unit(n); + test_strsv_upper_unit(n); + test_sger(n); + test_ssyr(n); + test_ssyr2(n); + test_sgbmv(n); + test_ssbmv(n); + test_stbmv(n); + test_stbsv(n); + test_sspmv(n); + test_stpmv(n); + test_stpsv(n); + test_sspr(n); + test_sspr2(n); + + test_dgemv_compact(n); + test_dsymv(n); + test_dtrmv(n); + test_dtrsv(n); + test_dtrmv_upper_unit(n); + test_dtrsv_upper_unit(n); + test_dger(n); + test_dsyr(n); + test_dsyr2(n); + test_dgbmv(n); + test_dsbmv(n); + test_dtbmv(n); + test_dtbsv(n); + test_dspmv(n); + test_dtpmv(n); + test_dtpsv(n); + test_dspr(n); + test_dspr2(n); + + test_cgemv(n); + test_cgemv_conjtrans(n); + test_chemv(n); + test_ctrmv(n); + test_ctrsv(n); + test_ctrmv_upper_unit(n); + test_ctrsv_upper_unit(n); + test_cgeru(n); + test_cgerc(n); + test_cher(n); + test_cher2(n); + test_cgbmv(n); + test_chbmv(n); + test_ctbmv(n); + test_ctbsv(n); + test_chpmv(n); + test_ctpmv(n); + test_ctpsv(n); + test_chpr(n); + test_chpr2(n); + + test_zgemv(n); + test_zgemv_conjtrans(n); + test_zhemv(n); + test_ztrmv(n); + test_ztrsv(n); + test_ztrmv_upper_unit(n); + test_ztrsv_upper_unit(n); + test_zgeru(n); + test_zgerc(n); + test_zher(n); + test_zher2(n); + test_zgbmv(n); + test_zhbmv(n); + test_ztbmv(n); + test_ztbsv(n); + test_zhpmv(n); + test_ztpmv(n); + test_ztpsv(n); + test_zhpr(n); + test_zhpr2(n); + } +} + +void check_l2(void) { + run_deep_gemv(); + run_compact_l2(); +} diff --git a/test/wasm/check_l3.c b/test/wasm/check_l3.c new file mode 100644 index 0000000000..77805186f2 --- /dev/null +++ b/test/wasm/check_l3.c @@ -0,0 +1,1649 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +/* + * Level-3 CBLAS checks vs the scalar oracle in ref_l3.c. + * + * Level-3 kernels are the blocked ones, so the interesting failures live at + * block and micro-tile remainders. Two grids are used: + * + * - Deep grids (SIZES_L3 / SIZES_CZ) for GEMM, SYRK, TRMM and TRSM. These + * sweep every transpose / uplo / side combination plus a few rectangular + * shapes, and reach sizes large enough to exercise the packing path. + * - A compact grid (SIZES_FULL) for the remaining standard Level-3 calls + * (SYMM, HEMM, complex SYRK/HERK, SYR2K/HER2K and the unit-diagonal + * TRMM/TRSM variants), which only need broad remainder sampling. + * + * One static test_* function per public CBLAS interface, or per distinct case + * where a single interface has several meaningful variants (left/right side, + * unit/non-unit diagonal). Each one allocates, fills, calls the scalar + * reference, calls OpenBLAS, then expect_close_* / expect_l3_*. + * + * All matrices are column major with the leading dimension equal to the + * number of rows unless the shape forces otherwise, and complex matrices are + * stored as interleaved re,im pairs. + */ + +#include "cases.h" +#include "common.h" +#include "ref.h" +#include "tol.h" + +/* ------------------------------------------------------------------------- */ +/* Shared helpers */ +/* ------------------------------------------------------------------------- */ + +/* Compact-grid comparison: the SIZES_FULL families all accumulate over n + * terms, and the rank-2k ones sum two such products per element, so they get + * twice the plain Level-3 budget. */ +static void expect_l3_f32(const char *op, int n, const float *got, + const float *ref, int z) { + char msg[96]; + + snprintf(msg, sizeof(msg), "%s n=%d", op, n); + expect_close_f32(msg, got, ref, z, tol_s_l3(n) * 2.0f); +} + +static void expect_l3_f64(const char *op, int n, const double *got, + const double *ref, int z) { + char msg[96]; + + snprintf(msg, sizeof(msg), "%s n=%d", op, n); + expect_close_f64(msg, got, ref, z, tol_d_l3(n) * 2.0); +} + +/* The lower-triangle forms of SYRK / HERK / SYR2K / HER2K leave the strictly + * upper triangle of C untouched, so zero it in both operands before + * comparing. `width` is 1 for real and 2 for interleaved complex matrices. */ +static void lower32(float *got, float *ref, int n, int width) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) + for (int q = 0; q < width; q++) { + got[width * (i + j * n) + q] = 0.0f; + ref[width * (i + j * n) + q] = 0.0f; + } +} + +static void lower64(double *got, double *ref, int n, int width) { + for (int j = 0; j < n; j++) + for (int i = 0; i < j; i++) + for (int q = 0; q < width; q++) { + got[width * (i + j * n) + q] = 0.0; + ref[width * (i + j * n) + q] = 0.0; + } +} + +/* Complex counterpart of make_tri_f32: a dense n-by-n triangular matrix with + * the other triangle explicitly zeroed, so the same buffer can be handed to + * the reference GEMM. The diagonal is real and well away from zero to keep + * TRSM well conditioned; `unit` materialises the implicit unit diagonal. */ +static void tri_c32(float *A, int n, enum CBLAS_UPLO uplo, int unit) { + memset(A, 0, (size_t)2 * n * n * sizeof(float)); + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + int in_triangle = (uplo == CblasLower) ? (i >= j) : (i <= j); + if (!in_triangle) + continue; + if (i == j) { + A[2 * (i + j * n)] = unit ? 1.0f : 2.2f + 0.02f * (float)i; + A[2 * (i + j * n) + 1] = 0.0f; + } else { + A[2 * (i + j * n)] = 0.07f * (float)(1 + (i + j) % 5); + A[2 * (i + j * n) + 1] = 0.03f * (float)(i - j); + } + } +} + +static void tri_c64(double *A, int n, enum CBLAS_UPLO uplo, int unit) { + memset(A, 0, (size_t)2 * n * n * sizeof(double)); + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + int in_triangle = (uplo == CblasLower) ? (i >= j) : (i <= j); + if (!in_triangle) + continue; + if (i == j) { + A[2 * (i + j * n)] = unit ? 1.0 : 2.2 + 0.02 * (double)i; + A[2 * (i + j * n) + 1] = 0.0; + } else { + A[2 * (i + j * n)] = 0.07 * (double)(1 + (i + j) % 5); + A[2 * (i + j * n) + 1] = 0.03 * (double)(i - j); + } + } +} + +/* a := alpha * a over n interleaved complex entries. */ +static void scale_c32(float *a, int n, const float *alpha) { + for (int i = 0; i < n; i++) { + float re = a[2 * i]; + float im = a[2 * i + 1]; + a[2 * i] = alpha[0] * re - alpha[1] * im; + a[2 * i + 1] = alpha[0] * im + alpha[1] * re; + } +} + +static void scale_c64(double *a, int n, const double *alpha) { + for (int i = 0; i < n; i++) { + double re = a[2 * i]; + double im = a[2 * i + 1]; + a[2 * i] = alpha[0] * re - alpha[1] * im; + a[2 * i + 1] = alpha[0] * im + alpha[1] * re; + } +} + +/* ------------------------------------------------------------------------- */ +/* Deep GEMM grid (all transpose combinations, square and rectangular) */ +/* ------------------------------------------------------------------------- */ + +/* sgemm: C := alpha * op(A) * op(B) + beta * C */ +static void test_sgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, + int n, int k) { + int lda = (ta == CblasNoTrans) ? m : k; + int ldb = (tb == CblasNoTrans) ? k : n; + int ldc = m; + int as = lda * ((ta == CblasNoTrans) ? k : m); + int bs = ldb * ((tb == CblasNoTrans) ? n : k); + float *A = xmalloc((size_t)as * sizeof(float)); + float *B = xmalloc((size_t)bs * sizeof(float)); + float *C = xmalloc((size_t)ldc * (size_t)n * sizeof(float)); + float *Cr = xmalloc((size_t)ldc * (size_t)n * sizeof(float)); + float alpha = 1.1f; + float beta = 0.7f; + char msg[160]; + + fill_f32(A, as, 1); + fill_f32(B, bs, 2); + fill_f32(C, ldc * n, 3); + memcpy(Cr, C, (size_t)ldc * (size_t)n * sizeof(float)); + + ref_sgemm(ta, tb, m, n, k, alpha, A, lda, B, ldb, beta, Cr, ldc); + cblas_sgemm(CblasColMajor, ta, tb, m, n, k, alpha, A, lda, B, ldb, beta, C, + ldc); + + snprintf(msg, sizeof(msg), "sgemm ta=%d tb=%d m=%d n=%d k=%d", (int)ta, + (int)tb, m, n, k); + expect_close_f32(msg, C, Cr, ldc * n, tol_s_l3(k)); + + free(A); + free(B); + free(C); + free(Cr); +} + +/* dgemm: C := alpha * op(A) * op(B) + beta * C */ +static void test_dgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, + int n, int k) { + int lda = (ta == CblasNoTrans) ? m : k; + int ldb = (tb == CblasNoTrans) ? k : n; + int ldc = m; + int as = lda * ((ta == CblasNoTrans) ? k : m); + int bs = ldb * ((tb == CblasNoTrans) ? n : k); + double *A = xmalloc((size_t)as * sizeof(double)); + double *B = xmalloc((size_t)bs * sizeof(double)); + double *C = xmalloc((size_t)ldc * (size_t)n * sizeof(double)); + double *Cr = xmalloc((size_t)ldc * (size_t)n * sizeof(double)); + double alpha = 1.1; + double beta = 0.7; + char msg[160]; + + fill_f64(A, as, 1); + fill_f64(B, bs, 2); + fill_f64(C, ldc * n, 3); + memcpy(Cr, C, (size_t)ldc * (size_t)n * sizeof(double)); + + ref_dgemm(ta, tb, m, n, k, alpha, A, lda, B, ldb, beta, Cr, ldc); + cblas_dgemm(CblasColMajor, ta, tb, m, n, k, alpha, A, lda, B, ldb, beta, C, + ldc); + + snprintf(msg, sizeof(msg), "dgemm ta=%d tb=%d m=%d n=%d k=%d", (int)ta, + (int)tb, m, n, k); + expect_close_f64(msg, C, Cr, ldc * n, tol_d_l3(k)); + + free(A); + free(B); + free(C); + free(Cr); +} + +/* cgemm: C := alpha * op(A) * op(B) + beta * C, op also covering conj-trans */ +static void test_cgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, + int n, int k) { + int lda = (ta == CblasNoTrans) ? m : k; + int ldb = (tb == CblasNoTrans) ? k : n; + int ldc = m; + int as = lda * ((ta == CblasNoTrans) ? k : m); + int bs = ldb * ((tb == CblasNoTrans) ? n : k); + float *A = xmalloc((size_t)as * 2 * sizeof(float)); + float *B = xmalloc((size_t)bs * 2 * sizeof(float)); + float *C = xmalloc((size_t)ldc * (size_t)n * 2 * sizeof(float)); + float *Cr = xmalloc((size_t)ldc * (size_t)n * 2 * sizeof(float)); + float alpha[2] = {1.1f, -0.3f}; + float beta[2] = {0.7f, 0.2f}; + char msg[160]; + + fill_c32(A, as, 1); + fill_c32(B, bs, 2); + fill_c32(C, ldc * n, 3); + memcpy(Cr, C, (size_t)ldc * (size_t)n * 2 * sizeof(float)); + + ref_cgemm(ta, tb, m, n, k, alpha, A, lda, B, ldb, beta, Cr, ldc); + cblas_cgemm(CblasColMajor, ta, tb, m, n, k, alpha, A, lda, B, ldb, beta, C, + ldc); + + snprintf(msg, sizeof(msg), "cgemm ta=%d tb=%d m=%d n=%d k=%d", (int)ta, + (int)tb, m, n, k); + /* A complex multiply-add is four real products, hence the extra factor. */ + expect_close_f32(msg, C, Cr, ldc * n * 2, tol_s_l3(k) * 2.0f); + + free(A); + free(B); + free(C); + free(Cr); +} + +/* zgemm: C := alpha * op(A) * op(B) + beta * C, op also covering conj-trans */ +static void test_zgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, + int n, int k) { + int lda = (ta == CblasNoTrans) ? m : k; + int ldb = (tb == CblasNoTrans) ? k : n; + int ldc = m; + int as = lda * ((ta == CblasNoTrans) ? k : m); + int bs = ldb * ((tb == CblasNoTrans) ? n : k); + double *A = xmalloc((size_t)as * 2 * sizeof(double)); + double *B = xmalloc((size_t)bs * 2 * sizeof(double)); + double *C = xmalloc((size_t)ldc * (size_t)n * 2 * sizeof(double)); + double *Cr = xmalloc((size_t)ldc * (size_t)n * 2 * sizeof(double)); + double alpha[2] = {1.1, -0.3}; + double beta[2] = {0.7, 0.2}; + char msg[160]; + + fill_c64(A, as, 1); + fill_c64(B, bs, 2); + fill_c64(C, ldc * n, 3); + memcpy(Cr, C, (size_t)ldc * (size_t)n * 2 * sizeof(double)); + + ref_zgemm(ta, tb, m, n, k, alpha, A, lda, B, ldb, beta, Cr, ldc); + cblas_zgemm(CblasColMajor, ta, tb, m, n, k, alpha, A, lda, B, ldb, beta, C, + ldc); + + snprintf(msg, sizeof(msg), "zgemm ta=%d tb=%d m=%d n=%d k=%d", (int)ta, + (int)tb, m, n, k); + expect_close_f64(msg, C, Cr, ldc * n * 2, tol_d_l3(k) * 2.0); + + free(A); + free(B); + free(C); + free(Cr); +} + +/* ------------------------------------------------------------------------- */ +/* Deep SYRK grid */ +/* ------------------------------------------------------------------------- */ + +/* ssyrk: C := alpha * A * A^T + beta * C (or A^T * A), one triangle only */ +static void test_ssyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, + int k) { + int lda = (trans == CblasNoTrans) ? n : k; + int as = lda * ((trans == CblasNoTrans) ? k : n); + float *A = xmalloc((size_t)as * sizeof(float)); + float *C = xmalloc((size_t)n * (size_t)n * sizeof(float)); + float *Cr = xmalloc((size_t)n * (size_t)n * sizeof(float)); + float alpha = 1.1f; + float beta = 0.7f; + char msg[160]; + + fill_f32(A, as, 6); + fill_f32(C, n * n, 7); + memcpy(Cr, C, (size_t)n * (size_t)n * sizeof(float)); + + ref_ssyrk(uplo, trans, n, k, alpha, A, lda, beta, Cr, n); + cblas_ssyrk(CblasColMajor, uplo, trans, n, k, alpha, A, lda, beta, C, n); + + /* Only compare the triangle that SYRK writes. */ + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + int keep = (uplo == CblasUpper) ? (i <= j) : (i >= j); + if (!keep) { + C[i + j * n] = 0.0f; + Cr[i + j * n] = 0.0f; + } + } + + snprintf(msg, sizeof(msg), "ssyrk uplo=%d t=%d n=%d k=%d", (int)uplo, + (int)trans, n, k); + expect_close_f32(msg, C, Cr, n * n, tol_s_l3(k)); + + free(A); + free(C); + free(Cr); +} + +/* dsyrk: C := alpha * A * A^T + beta * C (or A^T * A), one triangle only */ +static void test_dsyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, + int k) { + int lda = (trans == CblasNoTrans) ? n : k; + int as = lda * ((trans == CblasNoTrans) ? k : n); + double *A = xmalloc((size_t)as * sizeof(double)); + double *C = xmalloc((size_t)n * (size_t)n * sizeof(double)); + double *Cr = xmalloc((size_t)n * (size_t)n * sizeof(double)); + double alpha = 1.1; + double beta = 0.7; + char msg[160]; + + fill_f64(A, as, 6); + fill_f64(C, n * n, 7); + memcpy(Cr, C, (size_t)n * (size_t)n * sizeof(double)); + + ref_dsyrk(uplo, trans, n, k, alpha, A, lda, beta, Cr, n); + cblas_dsyrk(CblasColMajor, uplo, trans, n, k, alpha, A, lda, beta, C, n); + + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + int keep = (uplo == CblasUpper) ? (i <= j) : (i >= j); + if (!keep) { + C[i + j * n] = 0.0; + Cr[i + j * n] = 0.0; + } + } + + snprintf(msg, sizeof(msg), "dsyrk uplo=%d t=%d n=%d k=%d", (int)uplo, + (int)trans, n, k); + expect_close_f64(msg, C, Cr, n * n, tol_d_l3(k)); + + free(A); + free(C); + free(Cr); +} + +/* ------------------------------------------------------------------------- */ +/* Deep TRMM / TRSM grids */ +/* ------------------------------------------------------------------------- */ + +/* strmm: B := alpha * op(A) * B (left) or alpha * B * op(A) (right) */ +static void test_strmm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE t, int m, int n) { + int ka = (side == CblasLeft) ? m : n; + float *A = xmalloc((size_t)ka * (size_t)ka * sizeof(float)); + float *B = xmalloc((size_t)m * (size_t)n * sizeof(float)); + float *Br = xmalloc((size_t)m * (size_t)n * sizeof(float)); + float alpha = 1.1f; + char msg[160]; + + make_tri_f32(A, ka, ka, uplo, 0); + fill_f32(B, m * n, 8); + memcpy(Br, B, (size_t)m * (size_t)n * sizeof(float)); + + ref_strmm(side, uplo, t, CblasNonUnit, m, n, alpha, A, ka, Br, m); + cblas_strmm(CblasColMajor, side, uplo, t, CblasNonUnit, m, n, alpha, A, ka, B, + m); + + snprintf(msg, sizeof(msg), "strmm side=%d uplo=%d t=%d m=%d n=%d", (int)side, + (int)uplo, (int)t, m, n); + expect_close_f32(msg, B, Br, m * n, tol_s_l3(ka)); + + free(A); + free(B); + free(Br); +} + +/* dtrmm: B := alpha * op(A) * B (left) or alpha * B * op(A) (right) */ +static void test_dtrmm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE t, int m, int n) { + int ka = (side == CblasLeft) ? m : n; + double *A = xmalloc((size_t)ka * (size_t)ka * sizeof(double)); + double *B = xmalloc((size_t)m * (size_t)n * sizeof(double)); + double *Br = xmalloc((size_t)m * (size_t)n * sizeof(double)); + double alpha = 1.1; + char msg[160]; + + make_tri_f64(A, ka, ka, uplo, 0); + fill_f64(B, m * n, 8); + memcpy(Br, B, (size_t)m * (size_t)n * sizeof(double)); + + ref_dtrmm(side, uplo, t, CblasNonUnit, m, n, alpha, A, ka, Br, m); + cblas_dtrmm(CblasColMajor, side, uplo, t, CblasNonUnit, m, n, alpha, A, ka, B, + m); + + snprintf(msg, sizeof(msg), "dtrmm side=%d uplo=%d t=%d m=%d n=%d", (int)side, + (int)uplo, (int)t, m, n); + expect_close_f64(msg, B, Br, m * n, tol_d_l3(ka)); + + free(A); + free(B); + free(Br); +} + +/* strsm: solve op(A) X = B (left) or X op(A) = B (right), then check the + * reconstruction B ~= op(A) X rather than comparing against a reference + * solve, which would only restate the same rounding. */ +static void test_strsm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE t, int m, int n) { + int ka = (side == CblasLeft) ? m : n; + float *A = xmalloc((size_t)ka * (size_t)ka * sizeof(float)); + float *Ad = xmalloc((size_t)ka * (size_t)ka * sizeof(float)); + float *B0 = xmalloc((size_t)m * (size_t)n * sizeof(float)); + float *X = xmalloc((size_t)m * (size_t)n * sizeof(float)); + float *Bhat = xmalloc((size_t)m * (size_t)n * sizeof(float)); + float alpha = 1.0f; + char msg[160]; + + make_tri_f32(A, ka, ka, uplo, 0); + fill_f32(B0, m * n, 9); + memcpy(X, B0, (size_t)m * (size_t)n * sizeof(float)); + + cblas_strsm(CblasColMajor, side, uplo, t, CblasNonUnit, m, n, alpha, A, ka, X, + m); + + /* Dense copy of the referenced triangle so the reference GEMM can multiply + * it as an ordinary matrix. */ + memset(Ad, 0, (size_t)ka * (size_t)ka * sizeof(float)); + for (int j = 0; j < ka; j++) + for (int i = 0; i < ka; i++) { + int keep = (uplo == CblasLower) ? (i >= j) : (i <= j); + if (keep) + Ad[i + j * ka] = A[i + j * ka]; + } + + if (side == CblasLeft) + ref_sgemm(t, CblasNoTrans, m, n, m, 1.0f, Ad, ka, X, m, 0.0f, Bhat, m); + else + ref_sgemm(CblasNoTrans, t, m, n, n, 1.0f, X, m, Ad, ka, 0.0f, Bhat, m); + + snprintf(msg, sizeof(msg), "strsm side=%d uplo=%d t=%d m=%d n=%d", (int)side, + (int)uplo, (int)t, m, n); + expect_close_f32(msg, Bhat, B0, m * n, tol_s_l3(ka) * 2.0f); + + free(A); + free(Ad); + free(B0); + free(X); + free(Bhat); +} + +/* dtrsm: solve op(A) X = B (left) or X op(A) = B (right), checked by + * reconstructing B ~= op(A) X. */ +static void test_dtrsm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE t, int m, int n) { + int ka = (side == CblasLeft) ? m : n; + double *A = xmalloc((size_t)ka * (size_t)ka * sizeof(double)); + double *Ad = xmalloc((size_t)ka * (size_t)ka * sizeof(double)); + double *B0 = xmalloc((size_t)m * (size_t)n * sizeof(double)); + double *X = xmalloc((size_t)m * (size_t)n * sizeof(double)); + double *Bhat = xmalloc((size_t)m * (size_t)n * sizeof(double)); + double alpha = 1.0; + char msg[160]; + + make_tri_f64(A, ka, ka, uplo, 0); + fill_f64(B0, m * n, 9); + memcpy(X, B0, (size_t)m * (size_t)n * sizeof(double)); + + cblas_dtrsm(CblasColMajor, side, uplo, t, CblasNonUnit, m, n, alpha, A, ka, X, + m); + + memset(Ad, 0, (size_t)ka * (size_t)ka * sizeof(double)); + for (int j = 0; j < ka; j++) + for (int i = 0; i < ka; i++) { + int keep = (uplo == CblasLower) ? (i >= j) : (i <= j); + if (keep) + Ad[i + j * ka] = A[i + j * ka]; + } + + if (side == CblasLeft) + ref_dgemm(t, CblasNoTrans, m, n, m, 1.0, Ad, ka, X, m, 0.0, Bhat, m); + else + ref_dgemm(CblasNoTrans, t, m, n, n, 1.0, X, m, Ad, ka, 0.0, Bhat, m); + + snprintf(msg, sizeof(msg), "dtrsm side=%d uplo=%d t=%d m=%d n=%d", (int)side, + (int)uplo, (int)t, m, n); + expect_close_f64(msg, Bhat, B0, m * n, tol_d_l3(ka) * 2.0); + + free(A); + free(Ad); + free(B0); + free(X); + free(Bhat); +} + +/* ------------------------------------------------------------------------- */ +/* Compact grid: real single precision */ +/* ------------------------------------------------------------------------- */ + +/* ssymm (left, lower): C := alpha * A * B + beta * C with A symmetric */ +static void test_ssymm_left(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *B = xmalloc((size_t)nn * sizeof(float)); + float *C = xmalloc((size_t)nn * sizeof(float)); + float *R = xmalloc((size_t)nn * sizeof(float)); + float alpha = 0.8f; + float beta = -0.3f; + + fill_f32(A, nn, 80); + fill_f32(B, nn, 81); + fill_f32(C, nn, 82); + memcpy(R, C, (size_t)nn * sizeof(float)); + + ref_ssymm(CblasLeft, CblasLower, n, n, alpha, A, n, B, n, beta, R, n); + cblas_ssymm(CblasColMajor, CblasLeft, CblasLower, n, n, alpha, A, n, B, n, + beta, C, n); + + expect_l3_f32("ssymm-left", n, C, R, nn); + + free(A); + free(B); + free(C); + free(R); +} + +/* ssymm (right, upper): C := alpha * B * A + beta * C with A symmetric */ +static void test_ssymm_right(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *B = xmalloc((size_t)nn * sizeof(float)); + float *C = xmalloc((size_t)nn * sizeof(float)); + float *R = xmalloc((size_t)nn * sizeof(float)); + float alpha = 0.8f; + float beta = -0.3f; + + fill_f32(A, nn, 80); + fill_f32(B, nn, 81); + fill_f32(C, nn, 83); + memcpy(R, C, (size_t)nn * sizeof(float)); + + ref_ssymm(CblasRight, CblasUpper, n, n, alpha, A, n, B, n, beta, R, n); + cblas_ssymm(CblasColMajor, CblasRight, CblasUpper, n, n, alpha, A, n, B, n, + beta, C, n); + + expect_l3_f32("ssymm-right", n, C, R, nn); + + free(A); + free(B); + free(C); + free(R); +} + +/* ssyr2k (lower): C := alpha * A * B^T + alpha * B * A^T + beta * C */ +static void test_ssyr2k(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *B = xmalloc((size_t)nn * sizeof(float)); + float *C = xmalloc((size_t)nn * sizeof(float)); + float *R = xmalloc((size_t)nn * sizeof(float)); + float alpha = 0.8f; + float beta = -0.3f; + + fill_f32(A, nn, 84); + fill_f32(B, nn, 85); + fill_f32(C, nn, 86); + memcpy(R, C, (size_t)nn * sizeof(float)); + + ref_ssyr2k(CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, beta, R, n); + cblas_ssyr2k(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, + beta, C, n); + + lower32(C, R, n, 1); + expect_l3_f32("ssyr2k", n, C, R, nn); + + free(A); + free(B); + free(C); + free(R); +} + +/* strmm (left, lower, non-unit): B := alpha * A * B */ +static void test_strmm_full(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *B = xmalloc((size_t)nn * sizeof(float)); + float *R = xmalloc((size_t)nn * sizeof(float)); + float alpha = 0.8f; + + make_tri_f32(A, n, n, CblasLower, 0); + fill_f32(B, nn, 87); + memcpy(R, B, (size_t)nn * sizeof(float)); + + ref_strmm(CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, n, n, alpha, A, + n, R, n); + cblas_strmm(CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, + n, n, alpha, A, n, B, n); + + expect_l3_f32("strmm-full", n, B, R, nn); + + free(A); + free(B); + free(R); +} + +/* strsm (left, lower, non-unit): solving A X = alpha * A * B recovers + * X = alpha * B, so the expected result is known in closed form. */ +static void test_strsm_full(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *B = xmalloc((size_t)nn * sizeof(float)); + float *R = xmalloc((size_t)nn * sizeof(float)); + float alpha = 0.8f; + + make_tri_f32(A, n, n, CblasLower, 0); + fill_f32(B, nn, 87); + + /* Right-hand side alpha * A * B, built with the scalar reference. */ + ref_sgemm(CblasNoTrans, CblasNoTrans, n, n, n, alpha, A, n, B, n, 0.0f, R, n); + memcpy(B, R, (size_t)nn * sizeof(float)); + + cblas_strsm(CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, + n, n, 1.0f, A, n, B, n); + + fill_f32(R, nn, 87); + for (int i = 0; i < nn; i++) + R[i] *= alpha; + + expect_l3_f32("strsm-full", n, B, R, nn); + + free(A); + free(B); + free(R); +} + +/* strmm (right, upper, transposed, unit diagonal): B := alpha * B * A^T */ +static void test_strmm_right_unit(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *B = xmalloc((size_t)nn * sizeof(float)); + float *R = xmalloc((size_t)nn * sizeof(float)); + float alpha = 0.8f; + + make_tri_f32(A, n, n, CblasUpper, 1); + fill_f32(B, nn, 88); + memcpy(R, B, (size_t)nn * sizeof(float)); + + ref_strmm(CblasRight, CblasUpper, CblasTrans, CblasUnit, n, n, alpha, A, n, R, + n); + cblas_strmm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasUnit, n, + n, alpha, A, n, B, n); + + expect_l3_f32("strmm-right-unit", n, B, R, nn); + + free(A); + free(B); + free(R); +} + +/* strsm (right, upper, transposed, unit diagonal): solving X A^T = + * alpha * B * A^T recovers X = alpha * B. */ +static void test_strsm_right_unit(int n) { + int nn = n * n; + float *A = xmalloc((size_t)nn * sizeof(float)); + float *B = xmalloc((size_t)nn * sizeof(float)); + float *R = xmalloc((size_t)nn * sizeof(float)); + float alpha = 0.8f; + + make_tri_f32(A, n, n, CblasUpper, 1); + fill_f32(B, nn, 88); + + ref_sgemm(CblasNoTrans, CblasTrans, n, n, n, alpha, B, n, A, n, 0.0f, R, n); + memcpy(B, R, (size_t)nn * sizeof(float)); + + cblas_strsm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasUnit, n, + n, 1.0f, A, n, B, n); + + fill_f32(R, nn, 88); + for (int i = 0; i < nn; i++) + R[i] *= alpha; + + expect_l3_f32("strsm-right-unit", n, B, R, nn); + + free(A); + free(B); + free(R); +} + +/* ------------------------------------------------------------------------- */ +/* Compact grid: real double precision */ +/* ------------------------------------------------------------------------- */ + +/* dsymm (left, lower): C := alpha * A * B + beta * C with A symmetric */ +static void test_dsymm_left(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *B = xmalloc((size_t)nn * sizeof(double)); + double *C = xmalloc((size_t)nn * sizeof(double)); + double *R = xmalloc((size_t)nn * sizeof(double)); + double alpha = 0.8; + double beta = -0.3; + + fill_f64(A, nn, 80); + fill_f64(B, nn, 81); + fill_f64(C, nn, 82); + memcpy(R, C, (size_t)nn * sizeof(double)); + + ref_dsymm(CblasLeft, CblasLower, n, n, alpha, A, n, B, n, beta, R, n); + cblas_dsymm(CblasColMajor, CblasLeft, CblasLower, n, n, alpha, A, n, B, n, + beta, C, n); + + expect_l3_f64("dsymm-left", n, C, R, nn); + + free(A); + free(B); + free(C); + free(R); +} + +/* dsymm (right, upper): C := alpha * B * A + beta * C with A symmetric */ +static void test_dsymm_right(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *B = xmalloc((size_t)nn * sizeof(double)); + double *C = xmalloc((size_t)nn * sizeof(double)); + double *R = xmalloc((size_t)nn * sizeof(double)); + double alpha = 0.8; + double beta = -0.3; + + fill_f64(A, nn, 80); + fill_f64(B, nn, 81); + fill_f64(C, nn, 83); + memcpy(R, C, (size_t)nn * sizeof(double)); + + ref_dsymm(CblasRight, CblasUpper, n, n, alpha, A, n, B, n, beta, R, n); + cblas_dsymm(CblasColMajor, CblasRight, CblasUpper, n, n, alpha, A, n, B, n, + beta, C, n); + + expect_l3_f64("dsymm-right", n, C, R, nn); + + free(A); + free(B); + free(C); + free(R); +} + +/* dsyr2k (lower): C := alpha * A * B^T + alpha * B * A^T + beta * C */ +static void test_dsyr2k(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *B = xmalloc((size_t)nn * sizeof(double)); + double *C = xmalloc((size_t)nn * sizeof(double)); + double *R = xmalloc((size_t)nn * sizeof(double)); + double alpha = 0.8; + double beta = -0.3; + + fill_f64(A, nn, 84); + fill_f64(B, nn, 85); + fill_f64(C, nn, 86); + memcpy(R, C, (size_t)nn * sizeof(double)); + + ref_dsyr2k(CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, beta, R, n); + cblas_dsyr2k(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, + beta, C, n); + + lower64(C, R, n, 1); + expect_l3_f64("dsyr2k", n, C, R, nn); + + free(A); + free(B); + free(C); + free(R); +} + +/* dtrmm (left, lower, non-unit): B := alpha * A * B */ +static void test_dtrmm_full(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *B = xmalloc((size_t)nn * sizeof(double)); + double *R = xmalloc((size_t)nn * sizeof(double)); + double alpha = 0.8; + + make_tri_f64(A, n, n, CblasLower, 0); + fill_f64(B, nn, 87); + memcpy(R, B, (size_t)nn * sizeof(double)); + + ref_dtrmm(CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, n, n, alpha, A, + n, R, n); + cblas_dtrmm(CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, + n, n, alpha, A, n, B, n); + + expect_l3_f64("dtrmm-full", n, B, R, nn); + + free(A); + free(B); + free(R); +} + +/* dtrsm (left, lower, non-unit): solving A X = alpha * A * B recovers + * X = alpha * B. */ +static void test_dtrsm_full(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *B = xmalloc((size_t)nn * sizeof(double)); + double *R = xmalloc((size_t)nn * sizeof(double)); + double alpha = 0.8; + + make_tri_f64(A, n, n, CblasLower, 0); + fill_f64(B, nn, 87); + + ref_dgemm(CblasNoTrans, CblasNoTrans, n, n, n, alpha, A, n, B, n, 0.0, R, n); + memcpy(B, R, (size_t)nn * sizeof(double)); + + cblas_dtrsm(CblasColMajor, CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, + n, n, 1.0, A, n, B, n); + + fill_f64(R, nn, 87); + for (int i = 0; i < nn; i++) + R[i] *= alpha; + + expect_l3_f64("dtrsm-full", n, B, R, nn); + + free(A); + free(B); + free(R); +} + +/* dtrmm (right, upper, transposed, unit diagonal): B := alpha * B * A^T */ +static void test_dtrmm_right_unit(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *B = xmalloc((size_t)nn * sizeof(double)); + double *R = xmalloc((size_t)nn * sizeof(double)); + double alpha = 0.8; + + make_tri_f64(A, n, n, CblasUpper, 1); + fill_f64(B, nn, 88); + memcpy(R, B, (size_t)nn * sizeof(double)); + + ref_dtrmm(CblasRight, CblasUpper, CblasTrans, CblasUnit, n, n, alpha, A, n, R, + n); + cblas_dtrmm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasUnit, n, + n, alpha, A, n, B, n); + + expect_l3_f64("dtrmm-right-unit", n, B, R, nn); + + free(A); + free(B); + free(R); +} + +/* dtrsm (right, upper, transposed, unit diagonal): solving X A^T = + * alpha * B * A^T recovers X = alpha * B. */ +static void test_dtrsm_right_unit(int n) { + int nn = n * n; + double *A = xmalloc((size_t)nn * sizeof(double)); + double *B = xmalloc((size_t)nn * sizeof(double)); + double *R = xmalloc((size_t)nn * sizeof(double)); + double alpha = 0.8; + + make_tri_f64(A, n, n, CblasUpper, 1); + fill_f64(B, nn, 88); + + ref_dgemm(CblasNoTrans, CblasTrans, n, n, n, alpha, B, n, A, n, 0.0, R, n); + memcpy(B, R, (size_t)nn * sizeof(double)); + + cblas_dtrsm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasUnit, n, + n, 1.0, A, n, B, n); + + fill_f64(R, nn, 88); + for (int i = 0; i < nn; i++) + R[i] *= alpha; + + expect_l3_f64("dtrsm-right-unit", n, B, R, nn); + + free(A); + free(B); + free(R); +} + +/* ------------------------------------------------------------------------- */ +/* Compact grid: complex single precision */ +/* ------------------------------------------------------------------------- */ + +/* csymm (left, lower): C := alpha * A * B + beta * C with A complex + * symmetric (A = A^T, not Hermitian) */ +static void test_csymm(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *B = xmalloc((size_t)z * sizeof(float)); + float *C = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + fill_c32(A, nn, 90); + fill_c32(B, nn, 91); + fill_c32(C, nn, 92); + memcpy(R, C, (size_t)z * sizeof(float)); + + ref_csymm(CblasLeft, CblasLower, n, n, alpha, A, n, B, n, beta, R, n); + cblas_csymm(CblasColMajor, CblasLeft, CblasLower, n, n, alpha, A, n, B, n, + beta, C, n); + + expect_l3_f32("csymm", n, C, R, z); + + free(A); + free(B); + free(C); + free(R); +} + +/* chemm (left, lower): C := alpha * A * B + beta * C with A Hermitian */ +static void test_chemm(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *B = xmalloc((size_t)z * sizeof(float)); + float *C = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + fill_c32(A, nn, 90); + fill_c32(B, nn, 91); + fill_c32(C, nn, 93); + memcpy(R, C, (size_t)z * sizeof(float)); + + ref_chemm(CblasLeft, CblasLower, n, n, alpha, A, n, B, n, beta, R, n); + cblas_chemm(CblasColMajor, CblasLeft, CblasLower, n, n, alpha, A, n, B, n, + beta, C, n); + + expect_l3_f32("chemm", n, C, R, z); + + free(A); + free(B); + free(C); + free(R); +} + +/* csyrk (lower): C := alpha * A * A^T + beta * C */ +static void test_csyrk(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *C = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + fill_c32(A, nn, 94); + fill_c32(C, nn, 95); + memcpy(R, C, (size_t)z * sizeof(float)); + + ref_csyrk(CblasLower, CblasNoTrans, n, n, alpha, A, n, beta, R, n); + cblas_csyrk(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, beta, + C, n); + + lower32(C, R, n, 2); + expect_l3_f32("csyrk", n, C, R, z); + + free(A); + free(C); + free(R); +} + +/* cherk (lower): C := alpha * A * A^H + beta * C with real alpha and beta */ +static void test_cherk(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *C = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha = 0.7f; + float beta = -0.2f; + + fill_c32(A, nn, 94); + fill_c32(C, nn, 96); + /* A Hermitian C has a real diagonal, and HERK keeps it that way. */ + for (int i = 0; i < n; i++) + C[2 * (i + i * n) + 1] = 0.0f; + memcpy(R, C, (size_t)z * sizeof(float)); + + ref_cherk(CblasLower, CblasNoTrans, n, n, alpha, A, n, beta, R, n); + cblas_cherk(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, beta, + C, n); + + lower32(C, R, n, 2); + expect_l3_f32("cherk", n, C, R, z); + + free(A); + free(C); + free(R); +} + +/* csyr2k (lower): C := alpha * A * B^T + alpha * B * A^T + beta * C */ +static void test_csyr2k(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *B = xmalloc((size_t)z * sizeof(float)); + float *C = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta[2] = {-0.3f, 0.1f}; + + fill_c32(A, nn, 94); + fill_c32(B, nn, 97); + fill_c32(C, nn, 98); + memcpy(R, C, (size_t)z * sizeof(float)); + + ref_csyr2k(CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, beta, R, n); + cblas_csyr2k(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, + beta, C, n); + + lower32(C, R, n, 2); + expect_l3_f32("csyr2k", n, C, R, z); + + free(A); + free(B); + free(C); + free(R); +} + +/* cher2k (lower): C := alpha * A * B^H + conj(alpha) * B * A^H + beta * C + * with real beta */ +static void test_cher2k(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *B = xmalloc((size_t)z * sizeof(float)); + float *C = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float beta = -0.2f; + + fill_c32(A, nn, 94); + fill_c32(B, nn, 97); + fill_c32(C, nn, 101); + for (int i = 0; i < n; i++) + C[2 * (i + i * n) + 1] = 0.0f; + memcpy(R, C, (size_t)z * sizeof(float)); + + ref_cher2k(CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, beta, R, n); + cblas_cher2k(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, + beta, C, n); + + lower32(C, R, n, 2); + expect_l3_f32("cher2k", n, C, R, z); + + free(A); + free(B); + free(C); + free(R); +} + +/* ctrmm (left, lower, conj-transposed, non-unit): B := alpha * A^H * B */ +static void test_ctrmm(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *B = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float zero[2] = {0.0f, 0.0f}; + + tri_c32(A, n, CblasLower, 0); + fill_c32(B, nn, 99); + + ref_cgemm(CblasConjTrans, CblasNoTrans, n, n, n, alpha, A, n, B, n, zero, R, + n); + cblas_ctrmm(CblasColMajor, CblasLeft, CblasLower, CblasConjTrans, + CblasNonUnit, n, n, alpha, A, n, B, n); + + expect_l3_f32("ctrmm", n, B, R, z); + + free(A); + free(B); + free(R); +} + +/* ctrsm (left, lower, conj-transposed, non-unit): solving A^H X = + * alpha * A^H * B recovers X = alpha * B. */ +static void test_ctrsm(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *B = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + tri_c32(A, n, CblasLower, 0); + fill_c32(B, nn, 99); + + ref_cgemm(CblasConjTrans, CblasNoTrans, n, n, n, alpha, A, n, B, n, zero, R, + n); + memcpy(B, R, (size_t)z * sizeof(float)); + + cblas_ctrsm(CblasColMajor, CblasLeft, CblasLower, CblasConjTrans, + CblasNonUnit, n, n, one, A, n, B, n); + + fill_c32(R, nn, 99); + scale_c32(R, nn, alpha); + + expect_l3_f32("ctrsm", n, B, R, z); + + free(A); + free(B); + free(R); +} + +/* ctrmm (right, upper, transposed, unit diagonal): B := alpha * B * A^T */ +static void test_ctrmm_right_unit(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *B = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float zero[2] = {0.0f, 0.0f}; + + tri_c32(A, n, CblasUpper, 1); + fill_c32(B, nn, 100); + + ref_cgemm(CblasNoTrans, CblasTrans, n, n, n, alpha, B, n, A, n, zero, R, n); + cblas_ctrmm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasUnit, n, + n, alpha, A, n, B, n); + + expect_l3_f32("ctrmm-right-unit", n, B, R, z); + + free(A); + free(B); + free(R); +} + +/* ctrsm (right, upper, transposed, unit diagonal): solving X A^T = + * alpha * B * A^T recovers X = alpha * B. */ +static void test_ctrsm_right_unit(int n) { + int nn = n * n; + int z = 2 * nn; + float *A = xmalloc((size_t)z * sizeof(float)); + float *B = xmalloc((size_t)z * sizeof(float)); + float *R = xmalloc((size_t)z * sizeof(float)); + float alpha[2] = {0.8f, -0.2f}; + float one[2] = {1.0f, 0.0f}; + float zero[2] = {0.0f, 0.0f}; + + tri_c32(A, n, CblasUpper, 1); + fill_c32(B, nn, 100); + + ref_cgemm(CblasNoTrans, CblasTrans, n, n, n, alpha, B, n, A, n, zero, R, n); + memcpy(B, R, (size_t)z * sizeof(float)); + + cblas_ctrsm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasUnit, n, + n, one, A, n, B, n); + + fill_c32(R, nn, 100); + scale_c32(R, nn, alpha); + + expect_l3_f32("ctrsm-right-unit", n, B, R, z); + + free(A); + free(B); + free(R); +} + +/* ------------------------------------------------------------------------- */ +/* Compact grid: complex double precision */ +/* ------------------------------------------------------------------------- */ + +/* zsymm (left, lower): C := alpha * A * B + beta * C with A complex + * symmetric (A = A^T, not Hermitian) */ +static void test_zsymm(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *B = xmalloc((size_t)z * sizeof(double)); + double *C = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + fill_c64(A, nn, 90); + fill_c64(B, nn, 91); + fill_c64(C, nn, 92); + memcpy(R, C, (size_t)z * sizeof(double)); + + ref_zsymm(CblasLeft, CblasLower, n, n, alpha, A, n, B, n, beta, R, n); + cblas_zsymm(CblasColMajor, CblasLeft, CblasLower, n, n, alpha, A, n, B, n, + beta, C, n); + + expect_l3_f64("zsymm", n, C, R, z); + + free(A); + free(B); + free(C); + free(R); +} + +/* zhemm (left, lower): C := alpha * A * B + beta * C with A Hermitian */ +static void test_zhemm(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *B = xmalloc((size_t)z * sizeof(double)); + double *C = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + fill_c64(A, nn, 90); + fill_c64(B, nn, 91); + fill_c64(C, nn, 93); + memcpy(R, C, (size_t)z * sizeof(double)); + + ref_zhemm(CblasLeft, CblasLower, n, n, alpha, A, n, B, n, beta, R, n); + cblas_zhemm(CblasColMajor, CblasLeft, CblasLower, n, n, alpha, A, n, B, n, + beta, C, n); + + expect_l3_f64("zhemm", n, C, R, z); + + free(A); + free(B); + free(C); + free(R); +} + +/* zsyrk (lower): C := alpha * A * A^T + beta * C */ +static void test_zsyrk(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *C = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + fill_c64(A, nn, 94); + fill_c64(C, nn, 95); + memcpy(R, C, (size_t)z * sizeof(double)); + + ref_zsyrk(CblasLower, CblasNoTrans, n, n, alpha, A, n, beta, R, n); + cblas_zsyrk(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, beta, + C, n); + + lower64(C, R, n, 2); + expect_l3_f64("zsyrk", n, C, R, z); + + free(A); + free(C); + free(R); +} + +/* zherk (lower): C := alpha * A * A^H + beta * C with real alpha and beta */ +static void test_zherk(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *C = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha = 0.7; + double beta = -0.2; + + fill_c64(A, nn, 94); + fill_c64(C, nn, 96); + for (int i = 0; i < n; i++) + C[2 * (i + i * n) + 1] = 0.0; + memcpy(R, C, (size_t)z * sizeof(double)); + + ref_zherk(CblasLower, CblasNoTrans, n, n, alpha, A, n, beta, R, n); + cblas_zherk(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, beta, + C, n); + + lower64(C, R, n, 2); + expect_l3_f64("zherk", n, C, R, z); + + free(A); + free(C); + free(R); +} + +/* zsyr2k (lower): C := alpha * A * B^T + alpha * B * A^T + beta * C */ +static void test_zsyr2k(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *B = xmalloc((size_t)z * sizeof(double)); + double *C = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta[2] = {-0.3, 0.1}; + + fill_c64(A, nn, 94); + fill_c64(B, nn, 97); + fill_c64(C, nn, 98); + memcpy(R, C, (size_t)z * sizeof(double)); + + ref_zsyr2k(CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, beta, R, n); + cblas_zsyr2k(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, + beta, C, n); + + lower64(C, R, n, 2); + expect_l3_f64("zsyr2k", n, C, R, z); + + free(A); + free(B); + free(C); + free(R); +} + +/* zher2k (lower): C := alpha * A * B^H + conj(alpha) * B * A^H + beta * C + * with real beta */ +static void test_zher2k(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *B = xmalloc((size_t)z * sizeof(double)); + double *C = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double beta = -0.2; + + fill_c64(A, nn, 94); + fill_c64(B, nn, 97); + fill_c64(C, nn, 101); + for (int i = 0; i < n; i++) + C[2 * (i + i * n) + 1] = 0.0; + memcpy(R, C, (size_t)z * sizeof(double)); + + ref_zher2k(CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, beta, R, n); + cblas_zher2k(CblasColMajor, CblasLower, CblasNoTrans, n, n, alpha, A, n, B, n, + beta, C, n); + + lower64(C, R, n, 2); + expect_l3_f64("zher2k", n, C, R, z); + + free(A); + free(B); + free(C); + free(R); +} + +/* ztrmm (left, lower, conj-transposed, non-unit): B := alpha * A^H * B */ +static void test_ztrmm(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *B = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double zero[2] = {0.0, 0.0}; + + tri_c64(A, n, CblasLower, 0); + fill_c64(B, nn, 99); + + ref_zgemm(CblasConjTrans, CblasNoTrans, n, n, n, alpha, A, n, B, n, zero, R, + n); + cblas_ztrmm(CblasColMajor, CblasLeft, CblasLower, CblasConjTrans, + CblasNonUnit, n, n, alpha, A, n, B, n); + + expect_l3_f64("ztrmm", n, B, R, z); + + free(A); + free(B); + free(R); +} + +/* ztrsm (left, lower, conj-transposed, non-unit): solving A^H X = + * alpha * A^H * B recovers X = alpha * B. */ +static void test_ztrsm(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *B = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + tri_c64(A, n, CblasLower, 0); + fill_c64(B, nn, 99); + + ref_zgemm(CblasConjTrans, CblasNoTrans, n, n, n, alpha, A, n, B, n, zero, R, + n); + memcpy(B, R, (size_t)z * sizeof(double)); + + cblas_ztrsm(CblasColMajor, CblasLeft, CblasLower, CblasConjTrans, + CblasNonUnit, n, n, one, A, n, B, n); + + fill_c64(R, nn, 99); + scale_c64(R, nn, alpha); + + expect_l3_f64("ztrsm", n, B, R, z); + + free(A); + free(B); + free(R); +} + +/* ztrmm (right, upper, transposed, unit diagonal): B := alpha * B * A^T */ +static void test_ztrmm_right_unit(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *B = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double zero[2] = {0.0, 0.0}; + + tri_c64(A, n, CblasUpper, 1); + fill_c64(B, nn, 100); + + ref_zgemm(CblasNoTrans, CblasTrans, n, n, n, alpha, B, n, A, n, zero, R, n); + cblas_ztrmm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasUnit, n, + n, alpha, A, n, B, n); + + expect_l3_f64("ztrmm-right-unit", n, B, R, z); + + free(A); + free(B); + free(R); +} + +/* ztrsm (right, upper, transposed, unit diagonal): solving X A^T = + * alpha * B * A^T recovers X = alpha * B. */ +static void test_ztrsm_right_unit(int n) { + int nn = n * n; + int z = 2 * nn; + double *A = xmalloc((size_t)z * sizeof(double)); + double *B = xmalloc((size_t)z * sizeof(double)); + double *R = xmalloc((size_t)z * sizeof(double)); + double alpha[2] = {0.8, -0.2}; + double one[2] = {1.0, 0.0}; + double zero[2] = {0.0, 0.0}; + + tri_c64(A, n, CblasUpper, 1); + fill_c64(B, nn, 100); + + ref_zgemm(CblasNoTrans, CblasTrans, n, n, n, alpha, B, n, A, n, zero, R, n); + memcpy(B, R, (size_t)z * sizeof(double)); + + cblas_ztrsm(CblasColMajor, CblasRight, CblasUpper, CblasTrans, CblasUnit, n, + n, one, A, n, B, n); + + fill_c64(R, nn, 100); + scale_c64(R, nn, alpha); + + expect_l3_f64("ztrsm-right-unit", n, B, R, z); + + free(A); + free(B); + free(R); +} + +/* ------------------------------------------------------------------------- */ +/* Drivers */ +/* ------------------------------------------------------------------------- */ + +static void run_deep_gemm(void) { + enum CBLAS_TRANSPOSE tr[2] = {CblasNoTrans, CblasTrans}; + + printf("==> L3 GEMM\n"); + for (int s = 0; s < NS_L3; s++) { + int n = SIZES_L3[s]; + use_fill_case(s); + for (int ia = 0; ia < 2; ia++) + for (int ib = 0; ib < 2; ib++) { + test_sgemm(tr[ia], tr[ib], n, n, n); + test_dgemm(tr[ia], tr[ib], n, n, n); + /* Small sizes also get a non-square shape with a distinct k. */ + if (n <= 36) { + int m2 = n + 1; + int n2 = n > 1 ? n - 1 : n; + int k2 = n + 2; + test_sgemm(tr[ia], tr[ib], m2, n2, k2); + test_dgemm(tr[ia], tr[ib], m2, n2, k2); + } + } + } +} + +static void run_deep_complex_gemm(void) { + enum CBLAS_TRANSPOSE ctr[3] = {CblasNoTrans, CblasTrans, CblasConjTrans}; + + printf("==> L3 CGEMM/ZGEMM\n"); + for (int s = 0; s < NS_CZ; s++) { + int n = SIZES_CZ[s]; + use_fill_case(s); + for (int ia = 0; ia < 3; ia++) + for (int ib = 0; ib < 3; ib++) { + test_cgemm(ctr[ia], ctr[ib], n, n, n); + test_zgemm(ctr[ia], ctr[ib], n, n, n); + } + } +} + +static void run_deep_syrk(void) { + enum CBLAS_TRANSPOSE tr[2] = {CblasNoTrans, CblasTrans}; + enum CBLAS_UPLO uplos[2] = {CblasLower, CblasUpper}; + + printf("==> L3 SYRK\n"); + for (int s = 0; s < NS_L3; s++) { + int n = SIZES_L3[s]; + use_fill_case(s); + int k = n <= 36 ? n + 3 : n; + for (int u = 0; u < 2; u++) + for (int t = 0; t < 2; t++) { + test_ssyrk(uplos[u], tr[t], n, k); + test_dsyrk(uplos[u], tr[t], n, k); + } + } +} + +static void run_deep_trmm(void) { + enum CBLAS_TRANSPOSE tr[2] = {CblasNoTrans, CblasTrans}; + enum CBLAS_SIDE sides[2] = {CblasLeft, CblasRight}; + enum CBLAS_UPLO uplos[2] = {CblasLower, CblasUpper}; + + printf("==> L3 TRMM\n"); + for (int s = 0; s < NS_L3; s++) { + int n = SIZES_L3[s]; + use_fill_case(s); + for (int si = 0; si < 2; si++) + for (int u = 0; u < 2; u++) + for (int t = 0; t < 2; t++) { + test_strmm(sides[si], uplos[u], tr[t], n, n); + test_dtrmm(sides[si], uplos[u], tr[t], n, n); + if (n <= 36) { + int m2 = n + 1; + int n2 = n > 1 ? n - 1 : 1; + test_strmm(sides[si], uplos[u], tr[t], m2, n2); + test_dtrmm(sides[si], uplos[u], tr[t], m2, n2); + } + } + } +} + +static void run_deep_trsm(void) { + enum CBLAS_TRANSPOSE tr[2] = {CblasNoTrans, CblasTrans}; + enum CBLAS_SIDE sides[2] = {CblasLeft, CblasRight}; + enum CBLAS_UPLO uplos[2] = {CblasLower, CblasUpper}; + + printf("==> L3 TRSM\n"); + for (int s = 0; s < NS_L3; s++) { + int n = SIZES_L3[s]; + use_fill_case(s); + for (int si = 0; si < 2; si++) + for (int u = 0; u < 2; u++) + for (int t = 0; t < 2; t++) { + test_strsm(sides[si], uplos[u], tr[t], n, n); + test_dtrsm(sides[si], uplos[u], tr[t], n, n); + } + } +} + +static void run_compact_l3(void) { + printf("==> L3 SYMM/HEMM/SYRK/HERK/SYR2K/HER2K/TRMM/TRSM (compact grid)\n"); + for (int i = 0; i < NS_FULL; i++) { + int n = SIZES_FULL[i]; + use_fill_case(i); + + test_ssymm_left(n); + test_ssymm_right(n); + test_ssyr2k(n); + test_strmm_full(n); + test_strsm_full(n); + test_strmm_right_unit(n); + test_strsm_right_unit(n); + + test_dsymm_left(n); + test_dsymm_right(n); + test_dsyr2k(n); + test_dtrmm_full(n); + test_dtrsm_full(n); + test_dtrmm_right_unit(n); + test_dtrsm_right_unit(n); + + test_csymm(n); + test_chemm(n); + test_csyrk(n); + test_cherk(n); + test_csyr2k(n); + test_cher2k(n); + test_ctrmm(n); + test_ctrsm(n); + test_ctrmm_right_unit(n); + test_ctrsm_right_unit(n); + + test_zsymm(n); + test_zhemm(n); + test_zsyrk(n); + test_zherk(n); + test_zsyr2k(n); + test_zher2k(n); + test_ztrmm(n); + test_ztrsm(n); + test_ztrmm_right_unit(n); + test_ztrsm_right_unit(n); + } +} + +void check_l3(void) { + run_deep_gemm(); + run_deep_complex_gemm(); + run_deep_syrk(); + run_deep_trmm(); + run_deep_trsm(); + run_compact_l3(); +} diff --git a/test/wasm/common.h b/test/wasm/common.h new file mode 100644 index 0000000000..853e18b1be --- /dev/null +++ b/test/wasm/common.h @@ -0,0 +1,330 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +#ifndef TEST_WASM_COMMON_H +#define TEST_WASM_COMMON_H + +#include +#include +#include +#include + +#include "cblas.h" + +extern int g_fail; +extern int g_pass; + +/* Sign domain of generated values. Never includes 0. */ +typedef enum { + FILL_POS = 0, /* R^+ = (0, +inf) */ + FILL_NEG = 1, /* R^- = (-inf, 0) */ + FILL_REAL = 2, /* R \ {0}: mixed signs */ +} FillDomain; + +/* Magnitude spread. NEAR stays O(1) at the large end so the mixed + * absolute/relative tolerance in expect_close_* still gates kernel bugs. */ +typedef enum { + FILL_NEAR = 0, /* close to 0: log-uniform in [1e-4, 1] (f32) / [1e-8, 1] (f64) */ + FILL_FAR = 1, /* far from 0: log-uniform in [1e2, 1e4] (f32) / [1e4, 1e8] (f64) */ +} FillSpread; + +typedef struct { + FillDomain domain; + FillSpread spread; +} FillSpec; + +/* Active fill spec used by fill_vec_* / fill_mat_* / fill_f32 and friends. + * Drivers cycle FILL_CASES across the size grid (see use_fill_case). */ +extern FillSpec g_fill; + +static const FillSpec FILL_CASES[] = { + {FILL_POS, FILL_NEAR}, {FILL_POS, FILL_FAR}, {FILL_NEG, FILL_NEAR}, + {FILL_NEG, FILL_FAR}, {FILL_REAL, FILL_NEAR}, {FILL_REAL, FILL_FAR}, +}; +static const int NFILL_CASES = (int)(sizeof(FILL_CASES) / sizeof(FILL_CASES[0])); + +static inline void use_fill_case(int i) { + g_fill = FILL_CASES[(i < 0 ? 0 : i) % NFILL_CASES]; +} + +static inline const char *fill_spec_name(void) { + static const char *names[3][2] = { + {"R+ near 0", "R+ far from 0"}, + {"R- near 0", "R- far from 0"}, + {"R near 0", "R far from 0"}, + }; + return names[g_fill.domain][g_fill.spread]; +} + +static inline void *xmalloc(size_t n) { + void *p = malloc(n); + if (!p) { + fprintf(stderr, "oom (%zu)\n", n); + exit(1); + } + return p; +} + +static inline unsigned fill_hash(int i, int seed) { + unsigned x = (unsigned)i * 0x9e3779b9u + (unsigned)seed * 0x85ebca6bu; + x ^= x >> 16; + x *= 0x7feb352du; + x ^= x >> 15; + x *= 0x846ca68bu; + x ^= x >> 16; + return x; +} + +/* Deterministic (0, 1) from (index, seed). */ +static inline double fill_unit(int i, int seed) { + return ((double)(fill_hash(i, seed) % 1000003u) + 1.0) / 1000004.0; +} + +static inline float fill_mag_f32(int i, int seed, FillSpread spread) { + float t = (float)fill_unit(i, seed); + float log_lo = (spread == FILL_NEAR) ? logf(1e-4f) : logf(1e2f); + float log_hi = (spread == FILL_NEAR) ? logf(1.0f) : logf(1e4f); + return expf(log_lo + t * (log_hi - log_lo)); +} + +static inline double fill_mag_f64(int i, int seed, FillSpread spread) { + double t = fill_unit(i, seed); + double log_lo = (spread == FILL_NEAR) ? log(1e-8) : log(1e4); + double log_hi = (spread == FILL_NEAR) ? log(1.0) : log(1e8); + return exp(log_lo + t * (log_hi - log_lo)); +} + +static inline float fill_signed_f32(float mag, unsigned h, FillDomain domain) { + switch (domain) { + case FILL_POS: + return mag; + case FILL_NEG: + return -mag; + default: + return (h & 1u) ? mag : -mag; + } +} + +static inline double fill_signed_f64(double mag, unsigned h, FillDomain domain) { + switch (domain) { + case FILL_POS: + return mag; + case FILL_NEG: + return -mag; + default: + return (h & 1u) ? mag : -mag; + } +} + +/* Fill an n-vector from g_fill (strictly + / strictly − / mixed, near or far). */ +static inline void fill_vec_f32(float *x, int n, int seed) { + for (int i = 0; i < n; i++) { + unsigned h = fill_hash(i, seed); + x[i] = fill_signed_f32(fill_mag_f32(i, seed, g_fill.spread), h, + g_fill.domain); + } +} + +static inline void fill_vec_f64(double *x, int n, int seed) { + for (int i = 0; i < n; i++) { + unsigned h = fill_hash(i, seed); + x[i] = fill_signed_f64(fill_mag_f64(i, seed, g_fill.spread), h, + g_fill.domain); + } +} + +/* Column-major matrix: lda rows allocated, cols columns. Padding in the + * leading dimension is filled too, matching the existing dense fixtures. */ +static inline void fill_mat_f32(float *A, int rows, int cols, int lda, + int seed) { + (void)rows; + fill_vec_f32(A, lda * cols, seed); +} + +static inline void fill_mat_f64(double *A, int rows, int cols, int lda, + int seed) { + (void)rows; + fill_vec_f64(A, lda * cols, seed); +} + +static inline void fill_f32(float *a, int n, int seed) { + fill_vec_f32(a, n, seed); +} + +static inline void fill_f64(double *a, int n, int seed) { + fill_vec_f64(a, n, seed); +} + +/* Complex as interleaved re,im pairs (length 2*n floats/doubles). Each part + * follows the same real-line domain and spread as fill_vec_*. */ +static inline void fill_c32(float *a, int n, int seed) { + fill_vec_f32(a, 2 * n, seed); +} + +static inline void fill_c64(double *a, int n, int seed) { + fill_vec_f64(a, 2 * n, seed); +} + +static inline void fill_mat_c32(float *A, int rows, int cols, int lda, + int seed) { + (void)rows; + fill_vec_f32(A, 2 * lda * cols, seed); +} + +static inline void fill_mat_c64(double *A, int rows, int cols, int lda, + int seed) { + (void)rows; + fill_vec_f64(A, 2 * lda * cols, seed); +} + +/* Dense triangular fixture for TRMV/TRSV/TRMM/TRSM tests (real only). + * Intentionally independent of g_fill: O(1) diagonally-dominant entries keep + * triangular solves well-conditioned. */ +static inline void make_tri_f32(float *A, int n, int lda, enum CBLAS_UPLO uplo, + int unit) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + float v = 0.0f; + if (i == j) + v = unit ? 1.0f : (1.0f + 0.1f * (float)((i % 5) + 1)); + else if (uplo == CblasLower && i > j) + v = 0.1f * (float)((i + j) % 5 + 1); + else if (uplo == CblasUpper && i < j) + v = 0.1f * (float)((i + j) % 5 + 1); + A[i + j * lda] = v; + } +} + +static inline void make_tri_f64(double *A, int n, int lda, enum CBLAS_UPLO uplo, + int unit) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + double v = 0.0; + if (i == j) + v = unit ? 1.0 : (1.0 + 0.1 * (double)((i % 5) + 1)); + else if (uplo == CblasLower && i > j) + v = 0.1 * (double)((i + j) % 5 + 1); + else if (uplo == CblasUpper && i < j) + v = 0.1 * (double)((i + j) % 5 + 1); + A[i + j * lda] = v; + } +} + +static inline int close_f32(const float *got, const float *ref, int n, float tol, + float *out_maxe, float *out_maxv) { + float maxe = 0.0f, maxv = 0.0f; + for (int i = 0; i < n; i++) { + float e = fabsf(got[i] - ref[i]); + float v = fabsf(ref[i]); + if (e > maxe) + maxe = e; + if (v > maxv) + maxv = v; + } + if (out_maxe) + *out_maxe = maxe; + if (out_maxv) + *out_maxv = maxv; + return maxe <= tol * (1.0f + maxv); +} + +static inline int close_f64(const double *got, const double *ref, int n, + double tol, double *out_maxe, double *out_maxv) { + double maxe = 0.0, maxv = 0.0; + for (int i = 0; i < n; i++) { + double e = fabs(got[i] - ref[i]); + double v = fabs(ref[i]); + if (e > maxe) + maxe = e; + if (v > maxv) + maxv = v; + } + if (out_maxe) + *out_maxe = maxe; + if (out_maxv) + *out_maxv = maxv; + return maxe <= tol * (1.0 + maxv); +} + +static inline void pass_one(void) { g_pass++; } + +static inline void fail_f32(const char *msg, float maxe, float maxv, float tol) { + fprintf(stderr, "FAIL %s [%s] maxe=%.6g maxv=%.6g tol=%.6g\n", msg, + fill_spec_name(), maxe, maxv, tol); + g_fail++; +} + +static inline void fail_f64(const char *msg, double maxe, double maxv, + double tol) { + fprintf(stderr, "FAIL %s [%s] maxe=%.6g maxv=%.6g tol=%.6g\n", msg, + fill_spec_name(), maxe, maxv, tol); + g_fail++; +} + +/* Pass if got[] matches the scalar reference within relative tolerance. */ +static inline void expect_close_f32(const char *name, const float *got, + const float *ref, int n, float tol) { + float maxe; + float maxv; + + if (close_f32(got, ref, n, tol, &maxe, &maxv)) + pass_one(); + else + fail_f32(name, maxe, maxv, tol); +} + +/* Pass if got[] matches the scalar reference within relative tolerance. */ +static inline void expect_close_f64(const char *name, const double *got, + const double *ref, int n, double tol) { + double maxe; + double maxv; + + if (close_f64(got, ref, n, tol, &maxe, &maxv)) + pass_one(); + else + fail_f64(name, maxe, maxv, tol); +} + +/* Pass if an integer-sized result matches the scalar reference exactly. */ +static inline void expect_eq_size(const char *name, size_t got, size_t ref) { + if (got == ref) { + pass_one(); + return; + } + fprintf(stderr, "FAIL %s [%s] got=%zu ref=%zu\n", name, fill_spec_name(), got, + ref); + g_fail++; +} + +void check_l1(void); +void check_l2(void); +void check_l3(void); + +#endif /* TEST_WASM_COMMON_H */ diff --git a/test/wasm/main.c b/test/wasm/main.c new file mode 100644 index 0000000000..ee7544e7c5 --- /dev/null +++ b/test/wasm/main.c @@ -0,0 +1,50 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +#include "common.h" + +int g_fail; +int g_pass; +FillSpec g_fill = {FILL_REAL, FILL_NEAR}; + +int main(void) { + g_fail = 0; + g_pass = 0; +#ifdef TEST_WASM_RELAXED + printf("test/wasm numerical suite (relaxed SIMD tolerances)\n"); +#else + printf("test/wasm numerical suite (IEEE tolerances)\n"); +#endif + check_l1(); + check_l2(); + check_l3(); + printf("RESULTS: %d passed, %d failed\n", g_pass, g_fail); + return g_fail ? 1 : 0; +} diff --git a/test/wasm/ref.h b/test/wasm/ref.h new file mode 100644 index 0000000000..32e8d80f92 --- /dev/null +++ b/test/wasm/ref.h @@ -0,0 +1,171 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +#ifndef TEST_WASM_REF_H +#define TEST_WASM_REF_H + +#include + +#include "cblas.h" + +/* Level 1 typed (ref_l1.c) — deep AXPY grid. */ +void ref_saxpy(int n, float alpha, const float *x, int incx, float *y, + int incy); +void ref_daxpy(int n, double alpha, const double *x, int incx, double *y, + int incy); + +/* Level 2 typed (ref_l2.c) — deep GEMV grid. */ +void ref_sgemv(enum CBLAS_TRANSPOSE trans, int m, int n, float alpha, + const float *A, int lda, const float *x, int incx, float beta, + float *y, int incy); +void ref_dgemv(enum CBLAS_TRANSPOSE trans, int m, int n, double alpha, + const double *A, int lda, const double *x, int incx, double beta, + double *y, int incy); + +/* Level 3 (ref_l3.c). Symmetric, Hermitian and triangular routines read only + * the triangle named by `uplo`; rank-k / rank-2k write only that triangle. */ + +void ref_sgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, int n, + int k, float alpha, const float *A, int lda, const float *B, + int ldb, float beta, float *C, int ldc); +void ref_dgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, int n, + int k, double alpha, const double *A, int lda, const double *B, + int ldb, double beta, double *C, int ldc); +void ref_cgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, int n, + int k, const float *alpha, const float *A, int lda, + const float *B, int ldb, const float *beta, float *C, int ldc); +void ref_zgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, int n, + int k, const double *alpha, const double *A, int lda, + const double *B, int ldb, const double *beta, double *C, + int ldc); + +void ref_ssymm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + float alpha, const float *A, int lda, const float *B, int ldb, + float beta, float *C, int ldc); +void ref_dsymm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + double alpha, const double *A, int lda, const double *B, + int ldb, double beta, double *C, int ldc); +void ref_csymm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + const float *alpha, const float *A, int lda, const float *B, + int ldb, const float *beta, float *C, int ldc); +void ref_zsymm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + const double *alpha, const double *A, int lda, const double *B, + int ldb, const double *beta, double *C, int ldc); + +void ref_chemm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + const float *alpha, const float *A, int lda, const float *B, + int ldb, const float *beta, float *C, int ldc); +void ref_zhemm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + const double *alpha, const double *A, int lda, const double *B, + int ldb, const double *beta, double *C, int ldc); + +void ref_ssyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + float alpha, const float *A, int lda, float beta, float *C, + int ldc); +void ref_dsyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + double alpha, const double *A, int lda, double beta, double *C, + int ldc); +void ref_csyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const float *alpha, const float *A, int lda, const float *beta, + float *C, int ldc); +void ref_zsyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const double *alpha, const double *A, int lda, + const double *beta, double *C, int ldc); + +void ref_cherk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + float alpha, const float *A, int lda, float beta, float *C, + int ldc); +void ref_zherk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + double alpha, const double *A, int lda, double beta, double *C, + int ldc); + +void ref_ssyr2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + float alpha, const float *A, int lda, const float *B, int ldb, + float beta, float *C, int ldc); +void ref_dsyr2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + double alpha, const double *A, int lda, const double *B, + int ldb, double beta, double *C, int ldc); +void ref_csyr2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const float *alpha, const float *A, int lda, const float *B, + int ldb, const float *beta, float *C, int ldc); +void ref_zsyr2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const double *alpha, const double *A, int lda, + const double *B, int ldb, const double *beta, double *C, + int ldc); + +void ref_cher2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const float *alpha, const float *A, int lda, const float *B, + int ldb, float beta, float *C, int ldc); +void ref_zher2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const double *alpha, const double *A, int lda, + const double *B, int ldb, double beta, double *C, int ldc); + +void ref_strmm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE trans, enum CBLAS_DIAG diag, int m, int n, + float alpha, const float *A, int lda, float *B, int ldb); +void ref_dtrmm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE trans, enum CBLAS_DIAG diag, int m, int n, + double alpha, const double *A, int lda, double *B, int ldb); + +void ref_strsm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE trans, enum CBLAS_DIAG diag, int m, int n, + float alpha, const float *A, int lda, float *B, int ldb); +void ref_dtrsm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE trans, enum CBLAS_DIAG diag, int m, int n, + double alpha, const double *A, int lda, double *B, int ldb); + +void ref_l1_swap(int n, void *x, int incx, void *y, int incy, int width, + int is_double); +void ref_l1_copy(int n, const void *x, int incx, void *y, int incy, int width, + int is_double); +void ref_l1_scal(int n, const void *alpha, void *x, int incx, int width, + int is_double, int real_alpha); +void ref_l1_axpy(int n, const void *alpha, const void *x, int incx, void *y, + int incy, int width, int is_double); +void ref_l1_dot(int n, const void *x, int incx, const void *y, int incy, + void *out, int width, int is_double, int conjugate); +double ref_l1_nrm2(int n, const void *x, int incx, int width, int is_double); +double ref_l1_asum(int n, const void *x, int incx, int width, int is_double); +size_t ref_l1_iamax(int n, const void *x, int incx, int width, int is_double); +void ref_l1_rot(int n, void *x, int incx, void *y, int incy, double c, + double s, int width, int is_double); +void ref_l1_rotm(int n, void *x, int incx, void *y, int incy, + const void *param, int is_double); +void ref_l1_rotmg(void *d1, void *d2, void *b1, const void *b2, void *param, + int is_double); + +void ref_l2_mv(int n, const void *a, const void *x, void *y, + const void *alpha, const void *beta, int width, int is_double, + int conjugate); +void ref_l2_rank(int n, void *a, const void *x, const void *y, + const void *alpha, int width, int is_double, int conjugate_y, + int symmetric, int hermitian); + +#endif /* TEST_WASM_REF_H */ diff --git a/test/wasm/ref_l1.c b/test/wasm/ref_l1.c new file mode 100644 index 0000000000..4a78cf4645 --- /dev/null +++ b/test/wasm/ref_l1.c @@ -0,0 +1,306 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +#include "ref.h" + +#include + +/* Typed AXPY oracles for the deep remainder / stride grid in check_l1.c. */ + +void ref_saxpy(int n, float alpha, const float *x, int incx, float *y, + int incy) { + if (n <= 0) + return; + if (incx == 0 && incy == 0) { + y[0] += (float)n * alpha * x[0]; + return; + } + for (int i = 0; i < n; i++) + y[i * incy] += alpha * x[i * incx]; +} + +void ref_daxpy(int n, double alpha, const double *x, int incx, double *y, + int incy) { + if (n <= 0) + return; + if (incx == 0 && incy == 0) { + y[0] += (double)n * alpha * x[0]; + return; + } + for (int i = 0; i < n; i++) + y[i * incy] += alpha * x[i * incx]; +} + +static double getv(const void *p, int i, int is_double) { + return is_double ? ((const double *)p)[i] : ((const float *)p)[i]; +} + +static void setv(void *p, int i, int is_double, double v) { + if (is_double) + ((double *)p)[i] = v; + else + ((float *)p)[i] = (float)v; +} + +void ref_l1_swap(int n, void *x, int incx, void *y, int incy, int width, + int is_double) { + for (int i = 0; i < n; i++) + for (int q = 0; q < width; q++) { + int ix = width * i * incx + q, iy = width * i * incy + q; + double t = getv(x, ix, is_double); + setv(x, ix, is_double, getv(y, iy, is_double)); + setv(y, iy, is_double, t); + } +} + +void ref_l1_copy(int n, const void *x, int incx, void *y, int incy, int width, + int is_double) { + for (int i = 0; i < n; i++) + for (int q = 0; q < width; q++) + setv(y, width * i * incy + q, is_double, + getv(x, width * i * incx + q, is_double)); +} + +void ref_l1_scal(int n, const void *alpha, void *x, int incx, int width, + int is_double, int real_alpha) { + double ar = getv(alpha, 0, is_double); + double ai = real_alpha ? 0.0 : getv(alpha, 1, is_double); + for (int i = 0; i < n; i++) { + int k = width * i * incx; + double xr = getv(x, k, is_double); + if (width == 1) + setv(x, k, is_double, ar * xr); + else { + double xi = getv(x, k + 1, is_double); + setv(x, k, is_double, ar * xr - ai * xi); + setv(x, k + 1, is_double, ar * xi + ai * xr); + } + } +} + +void ref_l1_axpy(int n, const void *alpha, const void *x, int incx, void *y, + int incy, int width, int is_double) { + double ar = getv(alpha, 0, is_double); + double ai = width == 1 ? 0.0 : getv(alpha, 1, is_double); + for (int i = 0; i < n; i++) { + int ix = width * i * incx, iy = width * i * incy; + double xr = getv(x, ix, is_double), yr = getv(y, iy, is_double); + if (width == 1) + setv(y, iy, is_double, yr + ar * xr); + else { + double xi = getv(x, ix + 1, is_double); + double yi = getv(y, iy + 1, is_double); + setv(y, iy, is_double, yr + ar * xr - ai * xi); + setv(y, iy + 1, is_double, yi + ar * xi + ai * xr); + } + } +} + +void ref_l1_dot(int n, const void *x, int incx, const void *y, int incy, + void *out, int width, int is_double, int conjugate) { + double sr = 0.0, si = 0.0; + for (int i = 0; i < n; i++) { + int ix = width * i * incx, iy = width * i * incy; + double xr = getv(x, ix, is_double), yr = getv(y, iy, is_double); + if (width == 1) + sr += xr * yr; + else { + double xi = getv(x, ix + 1, is_double); + double yi = getv(y, iy + 1, is_double); + if (conjugate) + xi = -xi; + sr += xr * yr - xi * yi; + si += xr * yi + xi * yr; + } + } + setv(out, 0, is_double, sr); + if (width == 2) + setv(out, 1, is_double, si); +} + +double ref_l1_nrm2(int n, const void *x, int incx, int width, int is_double) { + double scale = 0.0, ssq = 1.0; + for (int i = 0; i < n; i++) + for (int q = 0; q < width; q++) { + double a = fabs(getv(x, width * i * incx + q, is_double)); + if (a != 0.0) { + if (scale < a) { + double r = scale / a; + ssq = 1.0 + ssq * r * r; + scale = a; + } else { + double r = a / scale; + ssq += r * r; + } + } + } + return scale == 0.0 ? 0.0 : scale * sqrt(ssq); +} + +double ref_l1_asum(int n, const void *x, int incx, int width, int is_double) { + double sum = 0.0; + for (int i = 0; i < n; i++) + for (int q = 0; q < width; q++) + sum += fabs(getv(x, width * i * incx + q, is_double)); + return sum; +} + +size_t ref_l1_iamax(int n, const void *x, int incx, int width, int is_double) { + size_t best = 0; + double vmax = -1.0; + for (int i = 0; i < n; i++) { + double v = 0.0; + for (int q = 0; q < width; q++) + v += fabs(getv(x, width * i * incx + q, is_double)); + if (v > vmax) { + vmax = v; + best = (size_t)i; + } + } + return n > 0 ? best : 0; +} + +void ref_l1_rot(int n, void *x, int incx, void *y, int incy, double c, + double s, int width, int is_double) { + for (int i = 0; i < n; i++) + for (int q = 0; q < width; q++) { + int ix = width * i * incx + q, iy = width * i * incy + q; + double xv = getv(x, ix, is_double), yv = getv(y, iy, is_double); + setv(x, ix, is_double, c * xv + s * yv); + setv(y, iy, is_double, c * yv - s * xv); + } +} + +void ref_l1_rotm(int n, void *x, int incx, void *y, int incy, + const void *param, int is_double) { + double flag = getv(param, 0, is_double); + if (flag == -2.0) + return; + double h11 = (flag < 0.0 || flag == 0.0) ? getv(param, 1, is_double) : 1.0; + double h21 = (flag < 0.0 || flag > 0.0) ? getv(param, 2, is_double) : -1.0; + double h12 = (flag < 0.0 || flag > 0.0) ? getv(param, 3, is_double) : 1.0; + double h22 = (flag < 0.0 || flag == 0.0) ? getv(param, 4, is_double) : 1.0; + for (int i = 0; i < n; i++) { + int ix = i * incx, iy = i * incy; + double w = getv(x, ix, is_double), z = getv(y, iy, is_double); + setv(x, ix, is_double, w * h11 + z * h12); + setv(y, iy, is_double, w * h21 + z * h22); + } +} + +/* + * Modified Givens generator (BLAS ROTMG). + * + * Updates d1, d2, b1 and writes param[0..4]: + * flag = param[0] selects which H entries are stored: + * -2 identity (early exit; no H written) + * -1 full H: h11, h21, h12, h22 in param[1..4] + * 0 off-diagonals only: h21, h12 (diags implied 1) + * 1 diagonals only: h11, h22 (off-diags implied -1 / 1) + * See Lawson et al. / Netlib drotmg for the case split on |q1| vs |q2|. + */ +void ref_l1_rotmg(void *d1p, void *d2p, void *b1p, const void *b2p, + void *param, int is_double) { + double d1 = getv(d1p, 0, is_double); + double d2 = getv(d2p, 0, is_double); + double b1 = getv(b1p, 0, is_double); + double b2 = getv(b2p, 0, is_double); + double flag = -1.0; + double h11 = 0.0, h12 = 0.0, h21 = 0.0, h22 = 0.0; + + if (d1 < 0.0) { + /* Negative d1: zero the state and return a full (zero) H. */ + flag = -1.0; + d1 = 0.0; + d2 = 0.0; + b1 = 0.0; + } else { + double p2 = d2 * b2; + if (p2 == 0.0) { + /* No second component: leave d1/d2/b1 unchanged, flag = -2. */ + setv(param, 0, is_double, -2.0); + return; + } + + double p1 = d1 * b1; + double q1 = p1 * b1; + double q2 = p2 * b2; + + if (fabs(q1) > fabs(q2)) { + /* Prefer scaling that keeps |h21|,|h12| from exploding. */ + h21 = -b2 / b1; + h12 = p2 / p1; + double u = 1.0 - h12 * h21; + if (u <= 0.0) { + flag = -1.0; + d1 = 0.0; + d2 = 0.0; + b1 = 0.0; + } else { + flag = 0.0; + d1 /= u; + d2 /= u; + b1 *= u; + } + } else if (q2 < 0.0) { + flag = -1.0; + d1 = 0.0; + d2 = 0.0; + b1 = 0.0; + } else { + h11 = p1 / p2; + h22 = b1 / b2; + double u = 1.0 + h11 * h22; + double tmp = d2 / u; + d2 = d1 / u; + d1 = tmp; + b1 = b2 * u; + flag = 1.0; + } + } + + setv(d1p, 0, is_double, d1); + setv(d2p, 0, is_double, d2); + setv(b1p, 0, is_double, b1); + setv(param, 0, is_double, flag); + + if (flag < 0.0) { + setv(param, 1, is_double, h11); + setv(param, 2, is_double, h21); + setv(param, 3, is_double, h12); + setv(param, 4, is_double, h22); + } else if (flag == 0.0) { + setv(param, 2, is_double, h21); + setv(param, 3, is_double, h12); + } else if (flag == 1.0) { + setv(param, 1, is_double, h11); + setv(param, 4, is_double, h22); + } +} diff --git a/test/wasm/ref_l2.c b/test/wasm/ref_l2.c new file mode 100644 index 0000000000..9389a6a010 --- /dev/null +++ b/test/wasm/ref_l2.c @@ -0,0 +1,189 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +#include "ref.h" + +/* Typed GEMV oracles for the deep shape / transpose / stride grid in + * check_l2.c. */ + +void ref_sgemv(enum CBLAS_TRANSPOSE trans, int m, int n, float alpha, + const float *A, int lda, const float *x, int incx, float beta, + float *y, int incy) { + int leny = (trans == CblasNoTrans) ? m : n; + int lenx = (trans == CblasNoTrans) ? n : m; + for (int i = 0; i < leny; i++) { + int yi = i * incy; + float s = 0.0f; + for (int j = 0; j < lenx; j++) { + int xj = j * incx; + float a = (trans == CblasNoTrans) ? A[i + j * lda] : A[j + i * lda]; + s += a * x[xj]; + } + if (beta == 0.0f) + y[yi] = alpha * s; + else + y[yi] = alpha * s + beta * y[yi]; + } +} + +void ref_dgemv(enum CBLAS_TRANSPOSE trans, int m, int n, double alpha, + const double *A, int lda, const double *x, int incx, double beta, + double *y, int incy) { + int leny = (trans == CblasNoTrans) ? m : n; + int lenx = (trans == CblasNoTrans) ? n : m; + for (int i = 0; i < leny; i++) { + int yi = i * incy; + double s = 0.0; + for (int j = 0; j < lenx; j++) { + int xj = j * incx; + double a = (trans == CblasNoTrans) ? A[i + j * lda] : A[j + i * lda]; + s += a * x[xj]; + } + if (beta == 0.0) + y[yi] = alpha * s; + else + y[yi] = alpha * s + beta * y[yi]; + } +} + +static double vget(const void *p, int i, int is_double) { + return is_double ? ((const double *)p)[i] : ((const float *)p)[i]; +} + +static void vset(void *p, int i, int is_double, double x) { + if (is_double) + ((double *)p)[i] = x; + else + ((float *)p)[i] = (float)x; +} + +/* Complex multiply: (ar + i*ai) * (br + i*bi). Real callers pass ai=bi=0. */ +static void cmul(double ar, double ai, double br, double bi, double *cr, + double *ci) { + *cr = ar * br - ai * bi; + *ci = ar * bi + ai * br; +} + +/* + * Dense matrix-vector product for the compact L2 suite: + * y := alpha * op(A) * x + beta * y + * with A n-by-n, unit strides, stored column-major. + * + * width 1 = real, 2 = complex (interleaved re,im) + * conjugate 0 = NoTrans (A[i,j]), 1 = ConjTrans (conj(A[j,i])) + */ +void ref_l2_mv(int n, const void *a, const void *x, void *y, + const void *alpha, const void *beta, int width, int is_double, + int conjugate) { + double alpha_r = vget(alpha, 0, is_double); + double alpha_i = (width == 2) ? vget(alpha, 1, is_double) : 0.0; + double beta_r = vget(beta, 0, is_double); + double beta_i = (width == 2) ? vget(beta, 1, is_double) : 0.0; + + for (int i = 0; i < n; i++) { + double sum_r = 0.0; + double sum_i = 0.0; + + for (int j = 0; j < n; j++) { + int ia = width * (conjugate ? (j + i * n) : (i + j * n)); + int ix = width * j; + double a_r = vget(a, ia, is_double); + double a_i = (width == 2) ? vget(a, ia + 1, is_double) : 0.0; + double x_r = vget(x, ix, is_double); + double x_i = (width == 2) ? vget(x, ix + 1, is_double) : 0.0; + double prod_r, prod_i; + + if (conjugate) + a_i = -a_i; + + cmul(a_r, a_i, x_r, x_i, &prod_r, &prod_i); + sum_r += prod_r; + sum_i += prod_i; + } + + int iy = width * i; + double y_r = vget(y, iy, is_double); + double y_i = (width == 2) ? vget(y, iy + 1, is_double) : 0.0; + double ax_r, ax_i, by_r, by_i; + + cmul(alpha_r, alpha_i, sum_r, sum_i, &ax_r, &ax_i); + cmul(beta_r, beta_i, y_r, y_i, &by_r, &by_i); + vset(y, iy, is_double, ax_r + by_r); + if (width == 2) + vset(y, iy + 1, is_double, ax_i + by_i); + } +} + +/* + * Rank-1 update for the compact L2 suite: + * A := A + alpha * x * y^T (or y^H if conjugate_y) + * + * If symmetric or hermitian is set, only the lower triangle (i >= j) is + * written. Hermitian updates force a zero imaginary part on the diagonal. + */ +void ref_l2_rank(int n, void *a, const void *x, const void *y, + const void *alpha, int width, int is_double, int conjugate_y, + int symmetric, int hermitian) { + double alpha_r = vget(alpha, 0, is_double); + double alpha_i = (width == 2) ? vget(alpha, 1, is_double) : 0.0; + + for (int j = 0; j < n; j++) { + for (int i = 0; i < n; i++) { + int ix, iy, ia; + double x_r, x_i, y_r, y_i; + double outer_r, outer_i, scaled_r, scaled_i; + + if ((symmetric || hermitian) && i < j) + continue; + + ix = width * i; + iy = width * j; + ia = width * (i + j * n); + + x_r = vget(x, ix, is_double); + x_i = (width == 2) ? vget(x, ix + 1, is_double) : 0.0; + y_r = vget(y, iy, is_double); + y_i = (width == 2) ? vget(y, iy + 1, is_double) : 0.0; + if (conjugate_y) + y_i = -y_i; + + cmul(x_r, x_i, y_r, y_i, &outer_r, &outer_i); + cmul(alpha_r, alpha_i, outer_r, outer_i, &scaled_r, &scaled_i); + + vset(a, ia, is_double, vget(a, ia, is_double) + scaled_r); + if (width == 2) { + double imag = (hermitian && i == j) + ? 0.0 + : vget(a, ia + 1, is_double) + scaled_i; + vset(a, ia + 1, is_double, imag); + } + } + } +} diff --git a/test/wasm/ref_l3.c b/test/wasm/ref_l3.c new file mode 100644 index 0000000000..7efcec39ab --- /dev/null +++ b/test/wasm/ref_l3.c @@ -0,0 +1,1049 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +/* + * Scalar IEEE Level-3 oracle for test/wasm. + * + * Plain triple loops using only IEEE `*` and `+`, so the result is + * independent of the SIMD, FMA and blocking choices made by the kernels under + * test. Matrices are column major and complex ones are interleaved re,im. + * + * The symmetric, Hermitian and triangular routines read only the triangle + * that UPLO declares as stored, and the rank-k / rank-2k routines write only + * that triangle, so callers do not have to mirror anything before or after. + */ + +#include "ref.h" + +#include +#include + +/* ------------------------------------------------------------------------- */ +/* Shared helpers */ +/* ------------------------------------------------------------------------- */ + +/* Does (i,j) fall in the triangle that `uplo` declares stored? */ +static int in_uplo(enum CBLAS_UPLO uplo, int i, int j) { + return (uplo == CblasUpper) ? (i <= j) : (i >= j); +} + +static void cmul_f32(float ar, float ai, float br, float bi, float *cr, + float *ci) { + *cr = ar * br - ai * bi; + *ci = ar * bi + ai * br; +} + +static void cmul_f64(double ar, double ai, double br, double bi, double *cr, + double *ci) { + *cr = ar * br - ai * bi; + *ci = ar * bi + ai * br; +} + +/* c := alpha * s + beta * c on one interleaved complex element. */ +static void caccum_f32(const float *alpha, float sr, float si, + const float *beta, float *c) { + float ar, ai; + + cmul_f32(alpha[0], alpha[1], sr, si, &ar, &ai); + if (beta[0] == 0.0f && beta[1] == 0.0f) { + c[0] = ar; + c[1] = ai; + } else { + float br, bi; + cmul_f32(beta[0], beta[1], c[0], c[1], &br, &bi); + c[0] = ar + br; + c[1] = ai + bi; + } +} + +static void caccum_f64(const double *alpha, double sr, double si, + const double *beta, double *c) { + double ar, ai; + + cmul_f64(alpha[0], alpha[1], sr, si, &ar, &ai); + if (beta[0] == 0.0 && beta[1] == 0.0) { + c[0] = ar; + c[1] = ai; + } else { + double br, bi; + cmul_f64(beta[0], beta[1], c[0], c[1], &br, &bi); + c[0] = ar + br; + c[1] = ai + bi; + } +} + +static void cget_f32(const float *A, int i, int j, int lda, + enum CBLAS_TRANSPOSE t, float *r, float *im) { + int idx; + if (t == CblasNoTrans) + idx = 2 * (i + j * lda); + else if (t == CblasTrans) + idx = 2 * (j + i * lda); + else /* ConjTrans */ + idx = 2 * (j + i * lda); + *r = A[idx]; + *im = A[idx + 1]; + if (t == CblasConjTrans) + *im = -*im; +} + +static void cget_f64(const double *A, int i, int j, int lda, + enum CBLAS_TRANSPOSE t, double *r, double *im) { + int idx; + if (t == CblasNoTrans) + idx = 2 * (i + j * lda); + else if (t == CblasTrans) + idx = 2 * (j + i * lda); + else + idx = 2 * (j + i * lda); + *r = A[idx]; + *im = A[idx + 1]; + if (t == CblasConjTrans) + *im = -*im; +} + +/* ------------------------------------------------------------------------- */ +/* GEMM */ +/* ------------------------------------------------------------------------- */ + +void ref_sgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, int n, + int k, float alpha, const float *A, int lda, const float *B, + int ldb, float beta, float *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + float s = 0.0f; + for (int p = 0; p < k; p++) { + float av = (ta == CblasNoTrans) ? A[i + p * lda] : A[p + i * lda]; + float bv = (tb == CblasNoTrans) ? B[p + j * ldb] : B[j + p * ldb]; + s += av * bv; + } + if (beta == 0.0f) + C[i + j * ldc] = alpha * s; + else + C[i + j * ldc] = alpha * s + beta * C[i + j * ldc]; + } +} + +void ref_dgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, int n, + int k, double alpha, const double *A, int lda, const double *B, + int ldb, double beta, double *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + double s = 0.0; + for (int p = 0; p < k; p++) { + double av = (ta == CblasNoTrans) ? A[i + p * lda] : A[p + i * lda]; + double bv = (tb == CblasNoTrans) ? B[p + j * ldb] : B[j + p * ldb]; + s += av * bv; + } + if (beta == 0.0) + C[i + j * ldc] = alpha * s; + else + C[i + j * ldc] = alpha * s + beta * C[i + j * ldc]; + } +} + +void ref_cgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, int n, + int k, const float *alpha, const float *A, int lda, + const float *B, int ldb, const float *beta, float *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + float sr = 0.0f, si = 0.0f; + for (int p = 0; p < k; p++) { + float ar, ai, br, bi, pr, pi; + cget_f32(A, i, p, lda, ta, &ar, &ai); + cget_f32(B, p, j, ldb, tb, &br, &bi); + cmul_f32(ar, ai, br, bi, &pr, &pi); + sr += pr; + si += pi; + } + caccum_f32(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +void ref_zgemm(enum CBLAS_TRANSPOSE ta, enum CBLAS_TRANSPOSE tb, int m, int n, + int k, const double *alpha, const double *A, int lda, + const double *B, int ldb, const double *beta, double *C, + int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + double sr = 0.0, si = 0.0; + for (int p = 0; p < k; p++) { + double ar, ai, br, bi, pr, pi; + cget_f64(A, i, p, lda, ta, &ar, &ai); + cget_f64(B, p, j, ldb, tb, &br, &bi); + cmul_f64(ar, ai, br, bi, &pr, &pi); + sr += pr; + si += pi; + } + caccum_f64(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +/* ------------------------------------------------------------------------- */ +/* SYMM / HEMM */ +/* ------------------------------------------------------------------------- */ + +/* A[i,j] of a symmetric matrix, taken from the stored triangle only. */ +static float sym_f32(const float *A, int lda, enum CBLAS_UPLO uplo, int i, + int j) { + return in_uplo(uplo, i, j) ? A[i + j * lda] : A[j + i * lda]; +} + +static double sym_f64(const double *A, int lda, enum CBLAS_UPLO uplo, int i, + int j) { + return in_uplo(uplo, i, j) ? A[i + j * lda] : A[j + i * lda]; +} + +/* Complex symmetric (A = A^T, no conjugation) element read. */ +static void csym_f32(const float *A, int lda, enum CBLAS_UPLO uplo, int i, + int j, float *re, float *im) { + int idx = in_uplo(uplo, i, j) ? 2 * (i + j * lda) : 2 * (j + i * lda); + *re = A[idx]; + *im = A[idx + 1]; +} + +static void csym_f64(const double *A, int lda, enum CBLAS_UPLO uplo, int i, + int j, double *re, double *im) { + int idx = in_uplo(uplo, i, j) ? 2 * (i + j * lda) : 2 * (j + i * lda); + *re = A[idx]; + *im = A[idx + 1]; +} + +/* Hermitian (A = A^H) element read: the diagonal is real by definition and + * the unstored triangle is the conjugate of the stored one. */ +static void herm_f32(const float *A, int lda, enum CBLAS_UPLO uplo, int i, + int j, float *re, float *im) { + if (i == j) { + *re = A[2 * (i + i * lda)]; + *im = 0.0f; + } else if (in_uplo(uplo, i, j)) { + *re = A[2 * (i + j * lda)]; + *im = A[2 * (i + j * lda) + 1]; + } else { + *re = A[2 * (j + i * lda)]; + *im = -A[2 * (j + i * lda) + 1]; + } +} + +static void herm_f64(const double *A, int lda, enum CBLAS_UPLO uplo, int i, + int j, double *re, double *im) { + if (i == j) { + *re = A[2 * (i + i * lda)]; + *im = 0.0; + } else if (in_uplo(uplo, i, j)) { + *re = A[2 * (i + j * lda)]; + *im = A[2 * (i + j * lda) + 1]; + } else { + *re = A[2 * (j + i * lda)]; + *im = -A[2 * (j + i * lda) + 1]; + } +} + +void ref_ssymm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + float alpha, const float *A, int lda, const float *B, int ldb, + float beta, float *C, int ldc) { + int ka = (side == CblasLeft) ? m : n; + + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + float s = 0.0f; + for (int p = 0; p < ka; p++) { + if (side == CblasLeft) + s += sym_f32(A, lda, uplo, i, p) * B[p + j * ldb]; + else + s += B[i + p * ldb] * sym_f32(A, lda, uplo, p, j); + } + if (beta == 0.0f) + C[i + j * ldc] = alpha * s; + else + C[i + j * ldc] = alpha * s + beta * C[i + j * ldc]; + } +} + +void ref_dsymm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + double alpha, const double *A, int lda, const double *B, + int ldb, double beta, double *C, int ldc) { + int ka = (side == CblasLeft) ? m : n; + + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + double s = 0.0; + for (int p = 0; p < ka; p++) { + if (side == CblasLeft) + s += sym_f64(A, lda, uplo, i, p) * B[p + j * ldb]; + else + s += B[i + p * ldb] * sym_f64(A, lda, uplo, p, j); + } + if (beta == 0.0) + C[i + j * ldc] = alpha * s; + else + C[i + j * ldc] = alpha * s + beta * C[i + j * ldc]; + } +} + +void ref_csymm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + const float *alpha, const float *A, int lda, const float *B, + int ldb, const float *beta, float *C, int ldc) { + int ka = (side == CblasLeft) ? m : n; + + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + float sr = 0.0f, si = 0.0f; + for (int p = 0; p < ka; p++) { + float ar, ai, br, bi, pr, pi; + int bidx; + if (side == CblasLeft) { + csym_f32(A, lda, uplo, i, p, &ar, &ai); + bidx = 2 * (p + j * ldb); + } else { + csym_f32(A, lda, uplo, p, j, &ar, &ai); + bidx = 2 * (i + p * ldb); + } + br = B[bidx]; + bi = B[bidx + 1]; + cmul_f32(ar, ai, br, bi, &pr, &pi); + sr += pr; + si += pi; + } + caccum_f32(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +void ref_zsymm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + const double *alpha, const double *A, int lda, const double *B, + int ldb, const double *beta, double *C, int ldc) { + int ka = (side == CblasLeft) ? m : n; + + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + double sr = 0.0, si = 0.0; + for (int p = 0; p < ka; p++) { + double ar, ai, br, bi, pr, pi; + int bidx; + if (side == CblasLeft) { + csym_f64(A, lda, uplo, i, p, &ar, &ai); + bidx = 2 * (p + j * ldb); + } else { + csym_f64(A, lda, uplo, p, j, &ar, &ai); + bidx = 2 * (i + p * ldb); + } + br = B[bidx]; + bi = B[bidx + 1]; + cmul_f64(ar, ai, br, bi, &pr, &pi); + sr += pr; + si += pi; + } + caccum_f64(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +void ref_chemm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + const float *alpha, const float *A, int lda, const float *B, + int ldb, const float *beta, float *C, int ldc) { + int ka = (side == CblasLeft) ? m : n; + + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + float sr = 0.0f, si = 0.0f; + for (int p = 0; p < ka; p++) { + float ar, ai, br, bi, pr, pi; + int bidx; + if (side == CblasLeft) { + herm_f32(A, lda, uplo, i, p, &ar, &ai); + bidx = 2 * (p + j * ldb); + } else { + herm_f32(A, lda, uplo, p, j, &ar, &ai); + bidx = 2 * (i + p * ldb); + } + br = B[bidx]; + bi = B[bidx + 1]; + cmul_f32(ar, ai, br, bi, &pr, &pi); + sr += pr; + si += pi; + } + caccum_f32(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +void ref_zhemm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, int m, int n, + const double *alpha, const double *A, int lda, const double *B, + int ldb, const double *beta, double *C, int ldc) { + int ka = (side == CblasLeft) ? m : n; + + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + double sr = 0.0, si = 0.0; + for (int p = 0; p < ka; p++) { + double ar, ai, br, bi, pr, pi; + int bidx; + if (side == CblasLeft) { + herm_f64(A, lda, uplo, i, p, &ar, &ai); + bidx = 2 * (p + j * ldb); + } else { + herm_f64(A, lda, uplo, p, j, &ar, &ai); + bidx = 2 * (i + p * ldb); + } + br = B[bidx]; + bi = B[bidx + 1]; + cmul_f64(ar, ai, br, bi, &pr, &pi); + sr += pr; + si += pi; + } + caccum_f64(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +/* ------------------------------------------------------------------------- */ +/* SYRK / HERK */ +/* ------------------------------------------------------------------------- */ + +void ref_ssyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + float alpha, const float *A, int lda, float beta, float *C, + int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + float s = 0.0f; + for (int p = 0; p < k; p++) { + float ai = (trans == CblasNoTrans) ? A[i + p * lda] : A[p + i * lda]; + float aj = (trans == CblasNoTrans) ? A[j + p * lda] : A[p + j * lda]; + s += ai * aj; + } + if (beta == 0.0f) + C[i + j * ldc] = alpha * s; + else + C[i + j * ldc] = alpha * s + beta * C[i + j * ldc]; + } +} + +void ref_dsyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + double alpha, const double *A, int lda, double beta, double *C, + int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + double s = 0.0; + for (int p = 0; p < k; p++) { + double ai = (trans == CblasNoTrans) ? A[i + p * lda] : A[p + i * lda]; + double aj = (trans == CblasNoTrans) ? A[j + p * lda] : A[p + j * lda]; + s += ai * aj; + } + if (beta == 0.0) + C[i + j * ldc] = alpha * s; + else + C[i + j * ldc] = alpha * s + beta * C[i + j * ldc]; + } +} + +void ref_csyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const float *alpha, const float *A, int lda, const float *beta, + float *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + float sr = 0.0f, si = 0.0f; + for (int p = 0; p < k; p++) { + int ia = (trans == CblasNoTrans) ? 2 * (i + p * lda) : 2 * (p + i * lda); + int ja = (trans == CblasNoTrans) ? 2 * (j + p * lda) : 2 * (p + j * lda); + float pr, pi; + cmul_f32(A[ia], A[ia + 1], A[ja], A[ja + 1], &pr, &pi); + sr += pr; + si += pi; + } + caccum_f32(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +void ref_zsyrk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const double *alpha, const double *A, int lda, + const double *beta, double *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + double sr = 0.0, si = 0.0; + for (int p = 0; p < k; p++) { + int ia = (trans == CblasNoTrans) ? 2 * (i + p * lda) : 2 * (p + i * lda); + int ja = (trans == CblasNoTrans) ? 2 * (j + p * lda) : 2 * (p + j * lda); + double pr, pi; + cmul_f64(A[ia], A[ia + 1], A[ja], A[ja + 1], &pr, &pi); + sr += pr; + si += pi; + } + caccum_f64(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +void ref_cherk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + float alpha, const float *A, int lda, float beta, float *C, + int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + float sr = 0.0f, si = 0.0f; + for (int p = 0; p < k; p++) { + float xr, xi, yr, yi, pr, pi; + if (trans == CblasNoTrans) { + /* A * A^H */ + xr = A[2 * (i + p * lda)]; + xi = A[2 * (i + p * lda) + 1]; + yr = A[2 * (j + p * lda)]; + yi = -A[2 * (j + p * lda) + 1]; + } else { + /* A^H * A */ + xr = A[2 * (p + i * lda)]; + xi = -A[2 * (p + i * lda) + 1]; + yr = A[2 * (p + j * lda)]; + yi = A[2 * (p + j * lda) + 1]; + } + cmul_f32(xr, xi, yr, yi, &pr, &pi); + sr += pr; + si += pi; + } + int cidx = 2 * (i + j * ldc); + if (beta == 0.0f) { + C[cidx] = alpha * sr; + C[cidx + 1] = alpha * si; + } else { + C[cidx] = alpha * sr + beta * C[cidx]; + C[cidx + 1] = alpha * si + beta * C[cidx + 1]; + } + if (i == j) + C[cidx + 1] = 0.0f; + } +} + +void ref_zherk(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + double alpha, const double *A, int lda, double beta, double *C, + int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + double sr = 0.0, si = 0.0; + for (int p = 0; p < k; p++) { + double xr, xi, yr, yi, pr, pi; + if (trans == CblasNoTrans) { + xr = A[2 * (i + p * lda)]; + xi = A[2 * (i + p * lda) + 1]; + yr = A[2 * (j + p * lda)]; + yi = -A[2 * (j + p * lda) + 1]; + } else { + xr = A[2 * (p + i * lda)]; + xi = -A[2 * (p + i * lda) + 1]; + yr = A[2 * (p + j * lda)]; + yi = A[2 * (p + j * lda) + 1]; + } + cmul_f64(xr, xi, yr, yi, &pr, &pi); + sr += pr; + si += pi; + } + int cidx = 2 * (i + j * ldc); + if (beta == 0.0) { + C[cidx] = alpha * sr; + C[cidx + 1] = alpha * si; + } else { + C[cidx] = alpha * sr + beta * C[cidx]; + C[cidx + 1] = alpha * si + beta * C[cidx + 1]; + } + if (i == j) + C[cidx + 1] = 0.0; + } +} + +/* ------------------------------------------------------------------------- */ +/* SYR2K / HER2K */ +/* ------------------------------------------------------------------------- */ + +void ref_ssyr2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + float alpha, const float *A, int lda, const float *B, int ldb, + float beta, float *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + float s = 0.0f; + for (int p = 0; p < k; p++) { + int no = (trans == CblasNoTrans); + float aip = no ? A[i + p * lda] : A[p + i * lda]; + float ajp = no ? A[j + p * lda] : A[p + j * lda]; + float bip = no ? B[i + p * ldb] : B[p + i * ldb]; + float bjp = no ? B[j + p * ldb] : B[p + j * ldb]; + s += aip * bjp + bip * ajp; + } + if (beta == 0.0f) + C[i + j * ldc] = alpha * s; + else + C[i + j * ldc] = alpha * s + beta * C[i + j * ldc]; + } +} + +void ref_dsyr2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + double alpha, const double *A, int lda, const double *B, + int ldb, double beta, double *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + double s = 0.0; + for (int p = 0; p < k; p++) { + int no = (trans == CblasNoTrans); + double aip = no ? A[i + p * lda] : A[p + i * lda]; + double ajp = no ? A[j + p * lda] : A[p + j * lda]; + double bip = no ? B[i + p * ldb] : B[p + i * ldb]; + double bjp = no ? B[j + p * ldb] : B[p + j * ldb]; + s += aip * bjp + bip * ajp; + } + if (beta == 0.0) + C[i + j * ldc] = alpha * s; + else + C[i + j * ldc] = alpha * s + beta * C[i + j * ldc]; + } +} + +void ref_csyr2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const float *alpha, const float *A, int lda, const float *B, + int ldb, const float *beta, float *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + float sr = 0.0f, si = 0.0f; + for (int p = 0; p < k; p++) { + int no = (trans == CblasNoTrans); + int ia = no ? 2 * (i + p * lda) : 2 * (p + i * lda); + int ja = no ? 2 * (j + p * lda) : 2 * (p + j * lda); + int ib = no ? 2 * (i + p * ldb) : 2 * (p + i * ldb); + int jb = no ? 2 * (j + p * ldb) : 2 * (p + j * ldb); + float pr, pi; + cmul_f32(A[ia], A[ia + 1], B[jb], B[jb + 1], &pr, &pi); + sr += pr; + si += pi; + cmul_f32(B[ib], B[ib + 1], A[ja], A[ja + 1], &pr, &pi); + sr += pr; + si += pi; + } + caccum_f32(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +void ref_zsyr2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const double *alpha, const double *A, int lda, const double *B, + int ldb, const double *beta, double *C, int ldc) { + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + double sr = 0.0, si = 0.0; + for (int p = 0; p < k; p++) { + int no = (trans == CblasNoTrans); + int ia = no ? 2 * (i + p * lda) : 2 * (p + i * lda); + int ja = no ? 2 * (j + p * lda) : 2 * (p + j * lda); + int ib = no ? 2 * (i + p * ldb) : 2 * (p + i * ldb); + int jb = no ? 2 * (j + p * ldb) : 2 * (p + j * ldb); + double pr, pi; + cmul_f64(A[ia], A[ia + 1], B[jb], B[jb + 1], &pr, &pi); + sr += pr; + si += pi; + cmul_f64(B[ib], B[ib + 1], A[ja], A[ja + 1], &pr, &pi); + sr += pr; + si += pi; + } + caccum_f64(alpha, sr, si, beta, &C[2 * (i + j * ldc)]); + } +} + +void ref_cher2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const float *alpha, const float *A, int lda, const float *B, + int ldb, float beta, float *C, int ldc) { + float conj_alpha[2] = {alpha[0], -alpha[1]}; + + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + /* s1 accumulates the alpha term, s2 the conj(alpha) one. */ + float s1r = 0.0f, s1i = 0.0f, s2r = 0.0f, s2i = 0.0f; + for (int p = 0; p < k; p++) { + float xr, xi, yr, yi, pr, pi; + if (trans == CblasNoTrans) { + /* A * B^H and B * A^H */ + xr = A[2 * (i + p * lda)]; + xi = A[2 * (i + p * lda) + 1]; + yr = B[2 * (j + p * ldb)]; + yi = -B[2 * (j + p * ldb) + 1]; + cmul_f32(xr, xi, yr, yi, &pr, &pi); + s1r += pr; + s1i += pi; + xr = B[2 * (i + p * ldb)]; + xi = B[2 * (i + p * ldb) + 1]; + yr = A[2 * (j + p * lda)]; + yi = -A[2 * (j + p * lda) + 1]; + } else { + /* A^H * B and B^H * A */ + xr = A[2 * (p + i * lda)]; + xi = -A[2 * (p + i * lda) + 1]; + yr = B[2 * (p + j * ldb)]; + yi = B[2 * (p + j * ldb) + 1]; + cmul_f32(xr, xi, yr, yi, &pr, &pi); + s1r += pr; + s1i += pi; + xr = B[2 * (p + i * ldb)]; + xi = -B[2 * (p + i * ldb) + 1]; + yr = A[2 * (p + j * lda)]; + yi = A[2 * (p + j * lda) + 1]; + } + cmul_f32(xr, xi, yr, yi, &pr, &pi); + s2r += pr; + s2i += pi; + } + float t1r, t1i, t2r, t2i; + cmul_f32(alpha[0], alpha[1], s1r, s1i, &t1r, &t1i); + cmul_f32(conj_alpha[0], conj_alpha[1], s2r, s2i, &t2r, &t2i); + int cidx = 2 * (i + j * ldc); + if (beta == 0.0f) { + C[cidx] = t1r + t2r; + C[cidx + 1] = t1i + t2i; + } else { + C[cidx] = t1r + t2r + beta * C[cidx]; + C[cidx + 1] = t1i + t2i + beta * C[cidx + 1]; + } + if (i == j) + C[cidx + 1] = 0.0f; + } +} + +void ref_zher2k(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, int n, int k, + const double *alpha, const double *A, int lda, + const double *B, int ldb, double beta, double *C, int ldc) { + double conj_alpha[2] = {alpha[0], -alpha[1]}; + + for (int j = 0; j < n; j++) + for (int i = 0; i < n; i++) { + if (!in_uplo(uplo, i, j)) + continue; + double s1r = 0.0, s1i = 0.0, s2r = 0.0, s2i = 0.0; + for (int p = 0; p < k; p++) { + double xr, xi, yr, yi, pr, pi; + if (trans == CblasNoTrans) { + xr = A[2 * (i + p * lda)]; + xi = A[2 * (i + p * lda) + 1]; + yr = B[2 * (j + p * ldb)]; + yi = -B[2 * (j + p * ldb) + 1]; + cmul_f64(xr, xi, yr, yi, &pr, &pi); + s1r += pr; + s1i += pi; + xr = B[2 * (i + p * ldb)]; + xi = B[2 * (i + p * ldb) + 1]; + yr = A[2 * (j + p * lda)]; + yi = -A[2 * (j + p * lda) + 1]; + } else { + xr = A[2 * (p + i * lda)]; + xi = -A[2 * (p + i * lda) + 1]; + yr = B[2 * (p + j * ldb)]; + yi = B[2 * (p + j * ldb) + 1]; + cmul_f64(xr, xi, yr, yi, &pr, &pi); + s1r += pr; + s1i += pi; + xr = B[2 * (p + i * ldb)]; + xi = -B[2 * (p + i * ldb) + 1]; + yr = A[2 * (p + j * lda)]; + yi = A[2 * (p + j * lda) + 1]; + } + cmul_f64(xr, xi, yr, yi, &pr, &pi); + s2r += pr; + s2i += pi; + } + double t1r, t1i, t2r, t2i; + cmul_f64(alpha[0], alpha[1], s1r, s1i, &t1r, &t1i); + cmul_f64(conj_alpha[0], conj_alpha[1], s2r, s2i, &t2r, &t2i); + int cidx = 2 * (i + j * ldc); + if (beta == 0.0) { + C[cidx] = t1r + t2r; + C[cidx + 1] = t1i + t2i; + } else { + C[cidx] = t1r + t2r + beta * C[cidx]; + C[cidx + 1] = t1i + t2i + beta * C[cidx + 1]; + } + if (i == j) + C[cidx + 1] = 0.0; + } +} + +/* ------------------------------------------------------------------------- */ +/* TRMM / TRSM */ +/* ------------------------------------------------------------------------- */ + +static float tri_a_f32(const float *A, int lda, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE t, enum CBLAS_DIAG diag, int i, + int j) { + int ii = i, jj = j; + if (t != CblasNoTrans) { + ii = j; + jj = i; + } + if (ii == jj) + return (diag == CblasUnit) ? 1.0f : A[ii + jj * lda]; + if (uplo == CblasLower) { + if (ii > jj) + return A[ii + jj * lda]; + return 0.0f; + } + if (ii < jj) + return A[ii + jj * lda]; + return 0.0f; +} + +static double tri_a_f64(const double *A, int lda, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE t, enum CBLAS_DIAG diag, int i, + int j) { + int ii = i, jj = j; + if (t != CblasNoTrans) { + ii = j; + jj = i; + } + if (ii == jj) + return (diag == CblasUnit) ? 1.0 : A[ii + jj * lda]; + if (uplo == CblasLower) { + if (ii > jj) + return A[ii + jj * lda]; + return 0.0; + } + if (ii < jj) + return A[ii + jj * lda]; + return 0.0; +} + +void ref_strmm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE trans, enum CBLAS_DIAG diag, int m, int n, + float alpha, const float *A, int lda, float *B, int ldb) { + float *T = (float *)malloc((size_t)m * (size_t)n * sizeof(float)); + if (!T) + exit(1); + memcpy(T, B, (size_t)m * (size_t)n * sizeof(float)); + if (side == CblasLeft) { + int ka = m; + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + float s = 0.0f; + for (int p = 0; p < ka; p++) + s += tri_a_f32(A, lda, uplo, trans, diag, i, p) * T[p + j * ldb]; + B[i + j * ldb] = alpha * s; + } + } else { + int ka = n; + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + float s = 0.0f; + for (int p = 0; p < ka; p++) + s += T[i + p * ldb] * tri_a_f32(A, lda, uplo, trans, diag, p, j); + B[i + j * ldb] = alpha * s; + } + } + free(T); +} + +void ref_dtrmm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE trans, enum CBLAS_DIAG diag, int m, int n, + double alpha, const double *A, int lda, double *B, int ldb) { + double *T = (double *)malloc((size_t)m * (size_t)n * sizeof(double)); + if (!T) + exit(1); + memcpy(T, B, (size_t)m * (size_t)n * sizeof(double)); + if (side == CblasLeft) { + int ka = m; + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + double s = 0.0; + for (int p = 0; p < ka; p++) + s += tri_a_f64(A, lda, uplo, trans, diag, i, p) * T[p + j * ldb]; + B[i + j * ldb] = alpha * s; + } + } else { + int ka = n; + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) { + double s = 0.0; + for (int p = 0; p < ka; p++) + s += T[i + p * ldb] * tri_a_f64(A, lda, uplo, trans, diag, p, j); + B[i + j * ldb] = alpha * s; + } + } + free(T); +} + +/* TRSM by forward / back substitution on the triangle that op(A) exposes; + * transposing swaps which of the two directions applies. */ + +static void trsm_left_f32(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, + enum CBLAS_DIAG diag, int m, int n, float alpha, + const float *A, int lda, float *B, int ldb) { + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) + B[i + j * ldb] *= alpha; + + int lower = (uplo == CblasLower) ^ (trans != CblasNoTrans); + if (lower) { + for (int j = 0; j < n; j++) { + for (int i = 0; i < m; i++) { + float s = B[i + j * ldb]; + for (int k = 0; k < i; k++) + s -= tri_a_f32(A, lda, uplo, trans, diag, i, k) * B[k + j * ldb]; + float d = tri_a_f32(A, lda, uplo, trans, diag, i, i); + B[i + j * ldb] = s / d; + } + } + } else { + for (int j = 0; j < n; j++) { + for (int i = m - 1; i >= 0; i--) { + float s = B[i + j * ldb]; + for (int k = i + 1; k < m; k++) + s -= tri_a_f32(A, lda, uplo, trans, diag, i, k) * B[k + j * ldb]; + float d = tri_a_f32(A, lda, uplo, trans, diag, i, i); + B[i + j * ldb] = s / d; + } + } + } +} + +static void trsm_right_f32(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, + enum CBLAS_DIAG diag, int m, int n, float alpha, + const float *A, int lda, float *B, int ldb) { + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) + B[i + j * ldb] *= alpha; + + int lower = (uplo == CblasLower) ^ (trans != CblasNoTrans); + if (lower) { + for (int j = n - 1; j >= 0; j--) { + for (int i = 0; i < m; i++) { + float s = B[i + j * ldb]; + for (int k = j + 1; k < n; k++) + s -= B[i + k * ldb] * tri_a_f32(A, lda, uplo, trans, diag, k, j); + float d = tri_a_f32(A, lda, uplo, trans, diag, j, j); + B[i + j * ldb] = s / d; + } + } + } else { + for (int j = 0; j < n; j++) { + for (int i = 0; i < m; i++) { + float s = B[i + j * ldb]; + for (int k = 0; k < j; k++) + s -= B[i + k * ldb] * tri_a_f32(A, lda, uplo, trans, diag, k, j); + float d = tri_a_f32(A, lda, uplo, trans, diag, j, j); + B[i + j * ldb] = s / d; + } + } + } +} + +static void trsm_left_f64(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, + enum CBLAS_DIAG diag, int m, int n, double alpha, + const double *A, int lda, double *B, int ldb) { + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) + B[i + j * ldb] *= alpha; + + int lower = (uplo == CblasLower) ^ (trans != CblasNoTrans); + if (lower) { + for (int j = 0; j < n; j++) { + for (int i = 0; i < m; i++) { + double s = B[i + j * ldb]; + for (int k = 0; k < i; k++) + s -= tri_a_f64(A, lda, uplo, trans, diag, i, k) * B[k + j * ldb]; + double d = tri_a_f64(A, lda, uplo, trans, diag, i, i); + B[i + j * ldb] = s / d; + } + } + } else { + for (int j = 0; j < n; j++) { + for (int i = m - 1; i >= 0; i--) { + double s = B[i + j * ldb]; + for (int k = i + 1; k < m; k++) + s -= tri_a_f64(A, lda, uplo, trans, diag, i, k) * B[k + j * ldb]; + double d = tri_a_f64(A, lda, uplo, trans, diag, i, i); + B[i + j * ldb] = s / d; + } + } + } +} + +static void trsm_right_f64(enum CBLAS_UPLO uplo, enum CBLAS_TRANSPOSE trans, + enum CBLAS_DIAG diag, int m, int n, double alpha, + const double *A, int lda, double *B, int ldb) { + for (int j = 0; j < n; j++) + for (int i = 0; i < m; i++) + B[i + j * ldb] *= alpha; + + int lower = (uplo == CblasLower) ^ (trans != CblasNoTrans); + if (lower) { + for (int j = n - 1; j >= 0; j--) { + for (int i = 0; i < m; i++) { + double s = B[i + j * ldb]; + for (int k = j + 1; k < n; k++) + s -= B[i + k * ldb] * tri_a_f64(A, lda, uplo, trans, diag, k, j); + double d = tri_a_f64(A, lda, uplo, trans, diag, j, j); + B[i + j * ldb] = s / d; + } + } + } else { + for (int j = 0; j < n; j++) { + for (int i = 0; i < m; i++) { + double s = B[i + j * ldb]; + for (int k = 0; k < j; k++) + s -= B[i + k * ldb] * tri_a_f64(A, lda, uplo, trans, diag, k, j); + double d = tri_a_f64(A, lda, uplo, trans, diag, j, j); + B[i + j * ldb] = s / d; + } + } + } +} + +void ref_strsm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE trans, enum CBLAS_DIAG diag, int m, int n, + float alpha, const float *A, int lda, float *B, int ldb) { + if (side == CblasLeft) + trsm_left_f32(uplo, trans, diag, m, n, alpha, A, lda, B, ldb); + else + trsm_right_f32(uplo, trans, diag, m, n, alpha, A, lda, B, ldb); +} + +void ref_dtrsm(enum CBLAS_SIDE side, enum CBLAS_UPLO uplo, + enum CBLAS_TRANSPOSE trans, enum CBLAS_DIAG diag, int m, int n, + double alpha, const double *A, int lda, double *B, int ldb) { + if (side == CblasLeft) + trsm_left_f64(uplo, trans, diag, m, n, alpha, A, lda, B, ldb); + else + trsm_right_f64(uplo, trans, diag, m, n, alpha, A, lda, B, ldb); +} diff --git a/test/wasm/run.sh b/test/wasm/run.sh new file mode 100755 index 0000000000..f224f9eb4b --- /dev/null +++ b/test/wasm/run.sh @@ -0,0 +1,133 @@ +#!/usr/bin/env bash +# Deep WASM numerical suite: scalar-oracle CBLAS checks under Node. +# Builds TARGET=WASM128_GENERIC twice (IEEE and relaxed SIMD) and runs the suite. +set -euo pipefail + +ROOT="$(cd "$(dirname "$0")/../.." && pwd)" +DIR="$ROOT/test/wasm" +OUT="${OUT:-$DIR/out}" +JOBS="${JOBS:-20}" +COMMON_OPT="${COMMON_OPT:--O2}" + +activate_emscripten() { + if command -v emcc >/dev/null 2>&1; then + return 0 + fi + local prefix="${OPENBLAS_EM_PREFIX:-}" + # Optional in-tree symlink/dir to an emscripten-forge prefix (not committed). + if [[ -z "$prefix" && -f "$ROOT/.em-prefix/bin/activate_emscripten.sh" ]]; then + prefix="$ROOT/.em-prefix" + fi + if [[ -z "$prefix" || ! -f "$prefix/bin/activate_emscripten.sh" ]]; then + echo "emcc not found. Set OPENBLAS_EM_PREFIX to an emscripten-forge env," >&2 + echo "or put activate_emscripten.sh under \$ROOT/.em-prefix/bin/." >&2 + exit 1 + fi + export CONDA_PREFIX="$prefix" + export PREFIX="${PREFIX:-$prefix}" + export PATH="$prefix/bin:$prefix/opt/emsdk/upstream/emscripten:$prefix/opt/emsdk/upstream/bin:$PATH" + export LDFLAGS="${LDFLAGS:-}" + export CFLAGS="${CFLAGS:-}" + # shellcheck disable=SC1091 + source "$prefix/bin/activate_emscripten.sh" +} + +activate_emscripten +mkdir -p "$OUT" +cd "$ROOT" + +SRCS=( + "$DIR/main.c" + "$DIR/ref_l1.c" + "$DIR/ref_l2.c" + "$DIR/ref_l3.c" + "$DIR/check_l1.c" + "$DIR/check_l2.c" + "$DIR/check_l3.c" +) + +LINKFLAGS=( + -O2 + -msimd128 + -sALLOW_MEMORY_GROWTH=1 + -sSTACK_SIZE=8MB + -sINITIAL_MEMORY=512MB + -sMAXIMUM_MEMORY=4GB + -sEXIT_RUNTIME=1 +) + +build_and_run() { + local relaxed="$1" + local tag + if [[ "$relaxed" == "1" ]]; then + tag="relaxed" + else + tag="ieee" + fi + + echo "==> make clean ($tag)" + # Host leftovers may make `make clean` fail under emcc (-march=native); still wipe objects. + emmake make clean COLORCODE=0 >/dev/null 2>&1 || true + find "$ROOT" -name '*.o' -not -path '*/.git/*' -not -path '*/test/wasm/out/*' -delete 2>/dev/null || true + rm -f "$ROOT"/libopenblas_wasm128*.a "$ROOT"/libopenblas.a + + echo "==> OpenBLAS libs TARGET=WASM128_GENERIC WASM_RELAXED_SIMD=$relaxed" + emmake make libs \ + -j"$JOBS" \ + HOSTCC=gcc \ + CC=emcc \ + AR=emar \ + RANLIB=emranlib \ + TARGET=WASM128_GENERIC \ + USE_THREAD=0 \ + WASM_RELAXED_SIMD="$relaxed" \ + NOFORTRAN=1 \ + NO_LAPACK=1 \ + NO_LAPACKE=1 \ + COMMON_OPT="$COMMON_OPT" \ + COLORCODE=0 + + local lib + lib=$(ls -1 "$ROOT"/libopenblas_wasm128*.a | head -n1) + if [[ -z "$lib" ]]; then + echo "libopenblas_wasm128*.a not found" >&2 + exit 1 + fi + + local defs=() + local lf=("${LINKFLAGS[@]}") + if [[ "$relaxed" == "1" ]]; then + defs+=(-DTEST_WASM_RELAXED) + lf+=(-mrelaxed-simd) + fi + + local js="$OUT/numerical_${tag}.js" + echo "==> linking $js" + emcc "${lf[@]}" "${defs[@]}" -I"$ROOT" -I"$DIR" -o "$js" "${SRCS[@]}" "$lib" + + echo "==> node $js" + node "$js" +} + +echo "test/wasm run.sh JOBS=$JOBS" +# If WASM_RELAXED_SIMD is set to 0 or 1, run only that mode (used by CI matrix). +# Otherwise run both IEEE and relaxed builds. +case "${WASM_RELAXED_SIMD-}" in + 0) + build_and_run 0 + echo "test/wasm: IEEE suite passed (WASM_RELAXED_SIMD=0)" + ;; + 1) + build_and_run 1 + echo "test/wasm: relaxed suite passed (WASM_RELAXED_SIMD=1)" + ;; + "") + build_and_run 0 + build_and_run 1 + echo "test/wasm: IEEE + relaxed suites passed" + ;; + *) + echo "WASM_RELAXED_SIMD must be unset, 0, or 1 (got: ${WASM_RELAXED_SIMD})" >&2 + exit 1 + ;; +esac diff --git a/test/wasm/tol.h b/test/wasm/tol.h new file mode 100644 index 0000000000..4a198ea17c --- /dev/null +++ b/test/wasm/tol.h @@ -0,0 +1,90 @@ +/* +Copyright (c) 2026, The OpenBLAS Project +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + 3. Neither the name of the OpenBLAS project nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBLAS PROJECT OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +*/ + +#ifndef TEST_WASM_TOL_H +#define TEST_WASM_TOL_H + +/* + * Relative pass condition (see expect_close_* in common.h): + * + * max_i |got[i] - ref[i]| <= tol * (1 + max_i |ref[i]|) + * + * So `tol` is a mixed absolute/relative budget: near zero it behaves like an + * absolute tolerance; for O(1) results it is relative. + * + * Choice of numbers + * ----------------- + * The scalar oracle uses only IEEE `*` / `+` (no FMA). OpenBLAS WASM kernels + * may reorder sums and, under WASM_RELAXED_SIMD, use f32x4.relaxed_madd / + * f64x2.relaxed_madd, which need not match IEEE fused multiply-add. + * + * Machine epsilons are ~1.2e-7 (f32) and ~2.2e-16 (f64). The budgets below + * are intentionally larger than a few ulps so the suite gates kernel bugs + * (wrong tiles, strides, remainders) rather than benign rounding differences. + * + * L1 (AXPY and friends): current WASM L1 paths stay ordinary mul+add even + * with -mrelaxed-simd, so a fixed, tight budget is enough (~30 ulp at |ref|~1 + * for f32). No dependence on n: depth of accumulation is small. + * + * L2 / L3: error can grow with the reduction length (inner dimension ~ n for + * the square cases we run). Budgets are therefore `SCALE * max(n, 1)`. + * IEEE SCALE is ~1.7e3 ulp (f32) / ~9e3 ulp (f64) per unit of n — loose + * enough for blocked GEMM/TRMM association, still far below what a wrong + * microkernel typically produces. Relaxed SCALE is 4× IEEE to cover + * relaxed_madd without hiding clear functional failures. + */ + +/* L2/L3 scale factors; multiplied by problem size in tol_*_l2 / tol_*_l3. */ +#ifdef TEST_WASM_RELAXED +#define TOL_S_SCALE 8e-4f +#define TOL_D_SCALE 8e-12 +#else +#define TOL_S_SCALE 2e-4f +#define TOL_D_SCALE 2e-12 +#endif + +/* Fixed L1 budgets (not scaled by n). */ +#define TOL_S_L1 4e-6f +#define TOL_D_L1 4e-14 + +static inline float tol_s_l3(int n) { + return TOL_S_SCALE * (float)(n > 0 ? n : 1); +} +static inline double tol_d_l3(int n) { + return TOL_D_SCALE * (double)(n > 0 ? n : 1); +} +static inline float tol_s_l2(int n) { + return TOL_S_SCALE * (float)(n > 0 ? n : 1); +} +static inline double tol_d_l2(int n) { + return TOL_D_SCALE * (double)(n > 0 ? n : 1); +} + +#endif /* TEST_WASM_TOL_H */