From 1d6afeea2b992f166dfba94fa4111dd96c3da44f Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Thu, 30 Apr 2026 18:41:31 -0300 Subject: [PATCH 01/11] system BLAS done, but not LAPACK --- BUILD.md | 41 ++++-- CMakeLists.txt | 146 ++++++++++++++---- dev_docs/lapack_unification_prompt.md | 204 ++++++++++++++++++++++++++ 3 files changed, 355 insertions(+), 36 deletions(-) create mode 100644 dev_docs/lapack_unification_prompt.md diff --git a/BUILD.md b/BUILD.md index 0cac5c5e..1d16173a 100644 --- a/BUILD.md +++ b/BUILD.md @@ -164,17 +164,36 @@ and run the appropriate `cmake` command again. ### "I'm getting cryptic linker errors related to BLAS!" -SuperLU requires BLAS. Its build script can look for and link against your -system's installed BLAS implementation (we recommend OpenBLAS). However, your -install might be lacking the appropriate static (`.a`) library files. - -If you don't know how to fix that and just want to build, you can use the -integrated BLAS subroutines bundled with the SuperLU source. To do that, run -the appropriate `cmake` command with the extra option -`-Denable_internal_blaslib=YES` *before* the `.` argument. - -Please be aware that the bundled CBLAS might be slow when compared to a proper -BLAS install. That might have an impact on the time it takes to run larger +MYSTRAN and SuperLU both need BLAS. The build system picks one of +three providers via the `MYSTRAN_BLAS` CMake option: + + - **`AUTO`** (default): try to locate a system BLAS (we recommend + OpenBLAS); if it isn't found, fall back to the bundled reference + routines. + - **`SYSTEM`**: require system BLAS; configuration fails with a + clear error if it cannot be found. + - **`EMBEDDED`**: ignore the system entirely and always compile in + MYSTRAN's bundled reference BLAS plus SuperLU's CBLAS. + +If the auto-detection picks up a BLAS that does not ship a static +`.a` archive (a common Windows situation), re-run CMake with +`-DMYSTRAN_BLAS=EMBEDDED` to force the bundled fallback. + +On Windows we ship fully static binaries, so when requesting +`SYSTEM` mode you must have a static OpenBLAS available +(MSYS2 / MinGW64: `pacman -S mingw-w64-x86_64-openblas`). + +The legacy `-Denable_internal_blaslib=YES` flag still works; it is +mapped to `-DMYSTRAN_BLAS=EMBEDDED` with a deprecation warning. + +LAPACK is always provided by MYSTRAN's bundled reference +implementation under `Source/Modules/LAPACK/`; system LAPACK is not +yet supported. (See `dev_docs/lapack_unification_prompt.md` for the +follow-up effort.) + +Please be aware that the bundled reference BLAS is considerably +slower than a tuned implementation like OpenBLAS or MKL. That can +have a significant impact on the time it takes to run larger models. --- diff --git a/CMakeLists.txt b/CMakeLists.txt index a6eacb37..8f7171d6 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -173,6 +173,103 @@ set(enable_examples OFF FORCE) set(enable_tests OFF FORCE) set(enable_doc OFF FORCE) +# ----------------------------------------------------------------------- +# BLAS provider resolution +# +# Single user-facing knob `MYSTRAN_BLAS` with three values: +# AUTO (default) - try system BLAS; fall back to embedded +# SYSTEM - require system BLAS; FATAL_ERROR if missing +# EMBEDDED - always use the bundled reference routines +# +# The mode is resolved here, BEFORE add_subdirectory() for SuperLU / +# SuperLU_MT, so we can forward the result to those subprojects via +# `TPL_BLAS_LIBRARIES` and `enable_internal_blaslib` and avoid duplicate +# symbols when statically linking on Windows (no symbol interposition). +# +# LAPACK is currently always embedded (Source/Modules/LAPACK/*.f). A +# follow-up effort will let SYSTEM mode also use a system LAPACK; see +# dev_docs/lapack_unification_prompt.md. +# ----------------------------------------------------------------------- + +# Backwards-compat: legacy `-Denable_internal_blaslib=...` maps to the new +# variable on first configure. We use an internal sentinel so the warning +# only fires when the user explicitly passed it on the command line. +if(DEFINED enable_internal_blaslib AND NOT _MYSTRAN_BLAS_LEGACY_MAPPED) + if(enable_internal_blaslib) + set(_LEGACY_MODE "EMBEDDED") + else() + set(_LEGACY_MODE "SYSTEM") + endif() + + message(DEPRECATION + "'enable_internal_blaslib' is deprecated; " + "use -DMYSTRAN_BLAS=${_LEGACY_MODE} instead.") + set(MYSTRAN_BLAS "${_LEGACY_MODE}" + CACHE STRING "BLAS provider: AUTO, SYSTEM, or EMBEDDED" FORCE) + set(_MYSTRAN_BLAS_LEGACY_MAPPED TRUE CACHE INTERNAL "") +endif() + +set(MYSTRAN_BLAS "AUTO" + CACHE STRING "BLAS provider: AUTO, SYSTEM, or EMBEDDED") +set_property(CACHE MYSTRAN_BLAS PROPERTY STRINGS AUTO SYSTEM EMBEDDED) + +if(NOT MYSTRAN_BLAS MATCHES "^(AUTO|SYSTEM|EMBEDDED)$") + message(FATAL_ERROR + "MYSTRAN_BLAS must be AUTO, SYSTEM, or EMBEDDED " + "(got '${MYSTRAN_BLAS}').") +endif() + +set(_MYSTRAN_HAVE_SYSTEM_BLAS FALSE) + +if(NOT MYSTRAN_BLAS STREQUAL "EMBEDDED") + if(TPL_BLAS_LIBRARIES) + set(BLAS_FOUND TRUE) + set(BLAS_LIBRARIES "${TPL_BLAS_LIBRARIES}") + else() + find_package(BLAS QUIET) + endif() + + if(BLAS_FOUND) + set(_MYSTRAN_HAVE_SYSTEM_BLAS TRUE) + endif() +endif() + +if(MYSTRAN_BLAS STREQUAL "SYSTEM" AND NOT _MYSTRAN_HAVE_SYSTEM_BLAS) + message(FATAL_ERROR + "MYSTRAN_BLAS=SYSTEM was requested but a system BLAS could not be " + "located.\n" + "Install OpenBLAS (Debian/Ubuntu: 'libopenblas-dev'; " + "MSYS2/MinGW64: 'mingw-w64-x86_64-openblas') or set TPL_BLAS_LIBRARIES " + "manually. Use -DMYSTRAN_BLAS=EMBEDDED to fall back to the bundled " + "reference routines.") +endif() + +if(_MYSTRAN_HAVE_SYSTEM_BLAS) + set(_MYSTRAN_BLAS_MODE "SYSTEM") +else() + set(_MYSTRAN_BLAS_MODE "EMBEDDED") +endif() + +# Forward the resolution to SuperLU / SuperLU_MT subprojects. They read +# `enable_internal_blaslib`, `TPL_ENABLE_INTERNAL_BLASLIB`, and +# `TPL_BLAS_LIBRARIES` to decide whether to build their bundled CBLAS. +if(_MYSTRAN_BLAS_MODE STREQUAL "SYSTEM") + set(TPL_BLAS_LIBRARIES "${BLAS_LIBRARIES}" + CACHE FILEPATH "Set from MYSTRAN BLAS resolution." FORCE) + set(enable_internal_blaslib OFF + CACHE BOOL "Use system BLAS for SuperLU" FORCE) + set(TPL_ENABLE_INTERNAL_BLASLIB OFF + CACHE BOOL "Use system BLAS for SuperLU" FORCE) + message(STATUS "MYSTRAN BLAS mode: SYSTEM (${BLAS_LIBRARIES})") +else() + set(enable_internal_blaslib ON + CACHE BOOL "Build internal CBLAS for SuperLU" FORCE) + set(TPL_ENABLE_INTERNAL_BLASLIB ON + CACHE BOOL "Build internal CBLAS for SuperLU" FORCE) + message(STATUS + "MYSTRAN BLAS mode: EMBEDDED (bundled reference routines)") +endif() + if(USE_SUPERLU_MT) message(STATUS "Will link against faster SuperLU_MT.") set(PLAT "_OPENMP" CACHE STRING "threading flavor _PTHREAD/_OPENMP" FORCE) @@ -346,36 +443,22 @@ file(GLOB_RECURSE ALL_FORTRAN_FILES "${CMAKE_SOURCE_DIR}/*.F03" ) -# same BLAS-finding subroutine as SuperLU -if(NOT enable_internal_blaslib) - if(TPL_BLAS_LIBRARIES) - set(BLAS_FOUND TRUE) - else() - find_package(BLAS) - - if(BLAS_FOUND) - set(TPL_BLAS_LIBRARIES "${BLAS_LIBRARIES}" CACHE FILEPATH - "Set from FindBLAS.cmake BLAS_LIBRARIES." FORCE) - endif() - endif() -endif() - -if(NOT BLAS_FOUND) - message(STATUS "BLAS not found, building local BLAS") +# Resolve BLAS linkage for the mystran target. The provider +# (SYSTEM vs EMBEDDED) was decided up top; here we only act on it. +if(_MYSTRAN_BLAS_MODE STREQUAL "EMBEDDED") + message(STATUS "Probing for missing BLAS routines to bundle locally") list( APPEND blas_fns dgemm dgemv dlamch dlanst dscal dsteqr dsterf dswap dtrsm dtrtri ilaenv lsame xerbla ) foreach(fname IN LISTS blas_fns) - # message(STATUS "Checking for BLAS subr ${fname}") set(CMAKE_REQUIRED_QUIET TRUE) check_function_exists("${fname}" BLAS_FN_EXISTS) unset(CMAKE_REQUIRED_QUIET) set(BLAS_FN_EXISTS CACHE "1" STRING) if(NOT BLAS_FN_EXISTS) - # message(STATUS "BLAS subr ${fname} not found") string(TOUPPER ${fname} fname_upper) list(APPEND missing_blas_src "${BLAS_SOURCE_DIR}/${fname_upper}.f") list(APPEND missing_blas_fns ${fname}) @@ -384,7 +467,6 @@ if(NOT BLAS_FOUND) unset(BLAS_FN_EXISTS CACHE) endforeach() - # if any subroutines have bene found, create an inner blas library list(LENGTH missing_blas_fns MISSING_FNS_TOTAL) if(MISSING_FNS_TOTAL GREATER 0) @@ -401,7 +483,11 @@ if(NOT BLAS_FOUND) endif() endif() else() - message(STATUS "Using system BLAS (${TPL_BLAS_LIBRARIES})") + # SYSTEM mode: do not bundle any BLAS reference routines. The embedded + # LAPACK modules under Source/Modules/LAPACK still build (their public + # names are module-mangled and do not collide with system LAPACK). + set(missing_blas_src "") + set(MISSING_FNS_TOTAL 0) endif() # prepare the main executable, linked against the specifics and the m @@ -433,6 +519,12 @@ else() target_link_libraries(mystran superlu f2c) endif() +# In SYSTEM mode, link the system BLAS after the SuperLU/f2c libraries +# so unresolved BLAS calls from those archives also get satisfied. +if(_MYSTRAN_BLAS_MODE STREQUAL "SYSTEM") + target_link_libraries(mystran ${BLAS_LIBRARIES}) +endif() + set_target_properties( mystran PROPERTIES RUNTIME_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR} ) @@ -525,6 +617,9 @@ list(JOIN _MYSTRAN_STATIC_NAMES ", " _STATIC_NAMES_STR) message(STATUS "Static libraries linked in: ${_STATIC_NAMES_STR}") # force some libraries +# LAPACK is currently always embedded (Source/Modules/LAPACK/*.f); the +# follow-up effort tracked in dev_docs/lapack_unification_prompt.md will +# make this conditional on _MYSTRAN_BLAS_MODE. list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_LAPACK) list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_ARPACK) @@ -794,15 +889,16 @@ else() endif() # BLAS source -if(BLAS_FOUND) - set(_BLAS_INFO "System BLAS: ${TPL_BLAS_LIBRARIES}") - string(REPLACE "'" "''" _BLAS_INFO "${_BLAS_INFO}") +if(_MYSTRAN_BLAS_MODE STREQUAL "SYSTEM") + set(_BLAS_INFO "System: ${BLAS_LIBRARIES}") elseif(MISSING_FNS_TOTAL GREATER 0) - set(_BLAS_INFO "CBLAS + built-in subset (${MISSING_FNS_TOTAL} routine(s) compiled in)") + set(_BLAS_INFO "Embedded reference (${MISSING_FNS_TOTAL} routine(s) compiled in)") else() - set(_BLAS_INFO "System BLAS") + set(_BLAS_INFO "System BLAS (provided by the OS, no routines compiled in)") endif() +string(REPLACE "'" "''" _BLAS_INFO "${_BLAS_INFO}") + # METIS if(TPL_ENABLE_METISLIB) set(_METIS_INFO "Enabled") diff --git a/dev_docs/lapack_unification_prompt.md b/dev_docs/lapack_unification_prompt.md new file mode 100644 index 00000000..d35a2baf --- /dev/null +++ b/dev_docs/lapack_unification_prompt.md @@ -0,0 +1,204 @@ +# LAPACK unification — follow-up agent prompt + +This document is the briefing for a future agent invocation that will +extend MYSTRAN's BLAS provider knob (`MYSTRAN_BLAS`) into a combined +`MYSTRAN_BLAS_LAPACK` knob, allowing MYSTRAN to use a system-provided +LAPACK (OpenBLAS / MKL / Netlib) instead of the embedded reference +implementations under `Source/Modules/LAPACK/`. + +The first half of the work — unifying BLAS — has already landed on the +`system_blas_fix` branch. This document captures everything the +follow-up agent needs to know about the LAPACK side so it does not have +to rediscover it. + +--- + +## Current state (post BLAS-only PR) + +- `MYSTRAN_BLAS={AUTO,SYSTEM,EMBEDDED}` is wired up in + [CMakeLists.txt](../CMakeLists.txt). It controls (a) whether + `BLAS/*.f` reference routines get bundled into mystran, (b) whether + SuperLU/SuperLU_MT build their own CBLAS, and (c) whether mystran is + linked against `${BLAS_LIBRARIES}`. +- Legacy `enable_internal_blaslib=YES/NO` still works and emits a + `DEPRECATION` warning that points at the new option. +- The build-info subroutines (`PRINT_BUILD_CONSTANTS`, + `PRINT_STATIC_LIB_LIST`) and the auto-generated license subroutines + read from the `_MYSTRAN_STATIC_DEFS` list and the + `_MYSTRAN_LICENSE_MAP`. `_STATIC_LAPACK` is currently force-appended + unconditionally — see the comment that explicitly flags it for this + follow-up. +- LAPACK is **always embedded**: every `Source/Modules/LAPACK/*.f` + module file is unconditionally compiled in via the + `file(GLOB_RECURSE ALL_FORTRAN_FILES ...)` in CMakeLists.txt. + +--- + +## Why LAPACK is harder than BLAS + +The embedded BLAS is **13 loose `.f` files** in `BLAS/`. Each defines +exactly one routine (e.g. `DGEMM.f` ⇒ `dgemm_`). They get included or +excluded as object files; system OpenBLAS provides identically-named +symbols, so all-or-nothing replacement at link time works trivially. + +The embedded LAPACK is **9 Fortran `MODULE`s** under +`Source/Modules/LAPACK/`, each containing many subroutines: + +| Module | Purpose | +|---|---| +| `LAPACK_BLAS_AUX` | Auxiliary routines used by other LAPACK code | +| `LAPACK_GIV_MGIV_EIG` | Generalised eigenvalue (Givens) helpers | +| `LAPACK_LANCZOS_EIG` | Lanczos eigenvalue helpers | +| `LAPACK_LIN_EQN_DGB` | General banded linear systems (DGBTRF/DGBTRS) | +| `LAPACK_LIN_EQN_DGE` | General dense linear systems (DGETRF/DGETRS) | +| `LAPACK_LIN_EQN_DPB` | Symmetric positive-definite banded | +| `LAPACK_MISCEL` | DSTEV, DSTERF, DSTEQR, DTRTRS | +| `LAPACK_STD_EIG_1` | DSYEV and friends | +| `LAPACK_SYM_MAT_INV` | DPOTRF/DPOTF2 | + +In total they define **95 procedures**. Because they are module +procedures, every consumer in the rest of MYSTRAN does +`USE LAPACK_` and the procedure references resolve at the +**source level** to module-mangled symbols +(`__lapack_blas_aux_MOD_dgemv` etc.). They never appear as bare +`dgemv_` symbols at link time and therefore *cannot* be silently +replaced by linking system LAPACK. + +There are roughly **70+ `USE LAPACK_*` sites** scattered across +`Source/`, including in the auto-generated `Source/Interfaces/*.f90` +files. + +--- + +## Routines that must stay embedded forever + +A grep of the module sources turns up at least four procedures that are +either MYSTRAN-specific or have non-standard signatures and have **no +direct system equivalent**: + +| Procedure | Reason | +|---|---| +| `DPTTRF_MYSTRAN` | MYSTRAN-specific name | +| `DSBGVX_GIV_MGIV` | Renamed/customized variant of LAPACK's `DSBGVX` | +| `DLACON(N, V, X, ISGN, EST, KASE, itmax)` | Extra `itmax` arg vs upstream `DLACON` | +| `EIGENVALUE_CONVERGENCE_FAILURE` | MYSTRAN error helper | + +Any other routines that have been locally patched (look for `! My ...` +comments and similar) need to stay too. **The audit below must +identify every such case.** + +--- + +## Recommended approach + +1. **Audit each of the 95 procedures** against the upstream Netlib + LAPACK reference (or whatever vintage of LAPACK these were copied + from — best guess from comments is LAPACK 3.x) and classify into: + - **Standard** — signature byte-for-byte identical to upstream + LAPACK. Safe to replace with an `INTERFACE` block in SYSTEM mode. + - **Custom** — different name, extra args, MYSTRAN error reporting, + or any other deviation. Must remain compiled in always. + Produce a Markdown table with one row per routine: name, module, + classification, notes. + +2. **Convert the 9 module files to use the C preprocessor.** They are + currently `.f` (no preprocessing). Either rename to `.F` or set + `set_source_files_properties(... PROPERTIES Fortran_PREPROCESS ON)`. + The codebase already uses uppercase `.F90` for some preprocessed + files, so renaming is consistent. + +3. **Restructure each module** as: + ```fortran + MODULE LAPACK_BLAS_AUX + ! ... existing USE statements ... + IMPLICIT NONE + #ifdef MYSTRAN_SYSTEM_LAPACK + INTERFACE + ! Explicit interface block per standard routine, copied + ! verbatim from netlib so INTENT/dimensions match exactly. + SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + ... + END SUBROUTINE DGEMV + ! ... + END INTERFACE + #endif + CONTAINS + #ifndef MYSTRAN_SYSTEM_LAPACK + ! All embedded standard-routine bodies. + #endif + ! Custom / always-compiled routines (DPTTRF_MYSTRAN, DLACON + ! with itmax, etc.) live outside the #ifdef and are always built. + END MODULE + ``` + +4. **CMake wiring** (small): + - Promote `MYSTRAN_BLAS` to `MYSTRAN_BLAS_LAPACK` (keep `MYSTRAN_BLAS` + as a deprecation alias the same way `enable_internal_blaslib` is + handled today). + - In SYSTEM mode also call `find_package(LAPACK)`; FATAL_ERROR if + missing. + - In SYSTEM mode: `target_compile_definitions(mystran PRIVATE + MYSTRAN_SYSTEM_LAPACK)` and append `${LAPACK_LIBRARIES}` to + `target_link_libraries(mystran ...)` (LAPACK before BLAS). + - Make `_STATIC_LAPACK` conditional on EMBEDDED mode (currently + unconditionally appended; the comment in CMakeLists.txt flags + this site explicitly). + - Restore the `_LAPACK_INFO` build-info field (it was added and + reverted during the BLAS-only PR — git log will show the diff). + - Update `BUILD.md` to describe the now-combined option and remove + the "LAPACK is always embedded" caveat. + +5. **Numerical regression testing.** Wrong INTENTs in interface blocks + produce silently wrong results. Run the full `Build_Test_Cases/` + statics + buckling + dynamics suite under both EMBEDDED and SYSTEM + modes and diff the outputs. Treat any diff beyond floating-point + noise as a bug in an interface block. + +--- + +## Key files / starting points + +- [CMakeLists.txt](../CMakeLists.txt) — search for + `MYSTRAN_BLAS`, `_MYSTRAN_BLAS_MODE`, `_STATIC_LAPACK`, `_BLAS_INFO`. +- [Source/Modules/LAPACK/](../Source/Modules/LAPACK) — the 9 files to + restructure. +- [BLAS/](../BLAS) — pattern for what loose-file standard routines look + like (this directory is *not* affected by the LAPACK work). +- [Source/MAIN/PRINT_BUILD_INFO.F90](../Source/MAIN/PRINT_BUILD_INFO.F90) + — already keys off `_STATIC_*` macros; nothing to change here. +- [BUILD.md](../BUILD.md) — user-facing docs. + +To enumerate every consumer: + +```bash +grep -rE '^\s+USE\s+LAPACK_' Source/ | sort -u +``` + +To list every procedure declared in the embedded modules: + +```bash +cd Source/Modules/LAPACK +grep -hE '^\s+(SUBROUTINE|.*FUNCTION)\s+[A-Z_][A-Z0-9_]*' *.f | sort -u +``` + +--- + +## Test environment + +- Linux dev machine has OpenBLAS at `/usr/lib/libopenblas.so` which + exposes the LAPACK API. `find_package(LAPACK)` succeeds out of the + box and reports `LAPACK_LIBRARIES = /usr/lib/libopenblas.so;-lm;-ldl`. +- Windows MSYS2 / MinGW64: `pacman -S mingw-w64-x86_64-openblas` + installs a static OpenBLAS that also covers LAPACK. + +--- + +## Decisions inherited from the BLAS-only PR + +- All-or-nothing replacement (no per-routine fallback). LAPACK follows + the same model — but "all" excludes the always-custom routines + enumerated above. +- Detection via `find_package(LAPACK)`, no symbol probing. +- Windows static-binary support is non-negotiable; OpenBLAS static + archive is the recommended provider. +- Legacy CMake flags get deprecation warnings, not removal. From 88e473226ab3b151bd69cab98f7c601a05df6d87 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Thu, 30 Apr 2026 19:28:12 -0300 Subject: [PATCH 02/11] attempted LAPACK surgery --- .gitmodules | 3 + BLAS/DGEMM.f | 324 - BLAS/DGEMV.f | 272 - BLAS/DLAMCH.f | 138 - BLAS/DLANST.f | 136 - BLAS/DSCAL.f | 56 - BLAS/DSTEQR.f | 516 - BLAS/DSTERF.f | 376 - BLAS/DSWAP.f | 69 - BLAS/DTRSM.f | 389 - BLAS/DTRTRI.f | 190 - BLAS/ILAENV.f | 549 - BLAS/LSAME.f | 90 - BLAS/XERBLA.f | 59 - BUILD.md | 52 +- CMakeLists.txt | 224 +- Source/Interfaces/CALC_GEN_MASS_Interface.f90 | 1 - Source/Interfaces/COND_NUM_Interface.f90 | 1 - Source/Interfaces/DSBAND_PREFAC_Interface.f90 | 2 - Source/Interfaces/EIG_GIV_MGIV_Interface.f90 | 3 +- Source/Interfaces/EIG_INV_PWR_Interface.f90 | 1 - .../EIG_LANCZOS_ARPACK_Interface.f90 | 2 +- Source/Interfaces/EPSCALC_Interface.f90 | 1 - Source/Interfaces/FBS_LAPACK_Interface.f90 | 1 - .../GET_MACHINE_PARAMS_Interface.f90 | 1 - Source/Interfaces/GPWG_PMOI_Interface.f90 | 1 - Source/Interfaces/INVERT_EIGENS_Interface.f90 | 1 - Source/Interfaces/INVERT_FF_MAT_Interface.f90 | 1 - Source/Interfaces/LINK3_Interface.f90 | 2 - Source/Interfaces/SOLVE_DLR_Interface.f90 | 1 - Source/Interfaces/SOLVE_GOA_Interface.f90 | 1 - Source/Interfaces/SOLVE_PHIZL1_Interface.f90 | 1 - Source/Interfaces/SOLVE_UO0_Interface.f90 | 1 - .../STIFF_MAT_EQUIL_CHK_Interface.f90 | 1 - .../SYM_MAT_DECOMP_LAPACK_Interface.f90 | 1 - Source/LK1/L1C/GPWG_PMOI.f90 | 1 - Source/LK1/L1E/KGG_SINGULARITY_PROC.f90 | 2 - Source/LK2/SOLVE_GMN.f90 | 1 - Source/LK2/SOLVE_GOA.f90 | 3 +- Source/LK2/SOLVE_UO0.f90 | 3 +- Source/LK2/STIFF_MAT_EQUIL_CHK.f90 | 5 +- Source/LK3/EPSCALC.f90 | 3 +- Source/LK3/LINK3.f90 | 2 - Source/LK4/CALC_GEN_MASS.f90 | 3 +- Source/LK4/DSBAND_PREFAC.f | 22 +- Source/LK4/EIG_GIV_MGIV.f90 | 4 +- Source/LK4/EIG_INV_PWR.f90 | 3 +- Source/LK4/EIG_LANCZOS_ARPACK.f90 | 4 +- Source/LK4/EIG_LANCZOS_ARPACK_ADAPTIVE.f90 | 2 - Source/LK4/INVERT_EIGENS.f90 | 1 - Source/LK6/SOLVE_DLR.f90 | 1 - Source/LK6/SOLVE_PHIZL1.f90 | 1 - Source/LK9/L91/PRINCIPAL_3D.f90 | 1 - Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f | 25 +- Source/Modules/LAPACK/LAPACK_BLAS_AUX.f | 11764 ---------------- Source/Modules/LAPACK/LAPACK_GIV_MGIV_EIG.f | 4094 ------ Source/Modules/LAPACK/LAPACK_LANCZOS_EIG.f | 370 - Source/Modules/LAPACK/LAPACK_LIN_EQN_DGB.f | 905 -- Source/Modules/LAPACK/LAPACK_LIN_EQN_DGE.f | 705 - Source/Modules/LAPACK/LAPACK_LIN_EQN_DPB.f | 2112 --- Source/Modules/LAPACK/LAPACK_MISCEL.f | 362 - Source/Modules/LAPACK/LAPACK_STD_EIG_1.f | 718 - Source/Modules/LAPACK/LAPACK_SYM_MAT_INV.f | 762 - .../MYSTRAN_LAPACK_EXT/MYSTRAN_LAPACK_EXT.f90 | 931 ++ Source/UTIL/COND_NUM.f90 | 5 +- Source/UTIL/FBS_LAPACK.f90 | 3 +- Source/UTIL/GET_MACHINE_PARAMS.f90 | 3 +- Source/UTIL/INVERT_FF_MAT.f90 | 1 - Source/UTIL/SYM_MAT_DECOMP_LAPACK.f90 | 5 +- Source/lapack | 1 + build/CPackConfig.cmake | 70 + build/CPackSourceConfig.cmake | 76 + build/superlu/FORTRAN/superlu_config.h | 24 + build/superlu/SRC/superluConfig.cmake | 39 + build/superlu/SRC/superluConfigVersion.cmake | 65 + build/superlu/SRC/superluTargets.cmake | 85 + build/superlu/SRC/superlu_config.h | 24 + build/superlu/superlu.pc | 12 + dev_docs/lapack_unification_prompt.md | 204 - 79 files changed, 1510 insertions(+), 25384 deletions(-) delete mode 100644 BLAS/DGEMM.f delete mode 100644 BLAS/DGEMV.f delete mode 100644 BLAS/DLAMCH.f delete mode 100644 BLAS/DLANST.f delete mode 100644 BLAS/DSCAL.f delete mode 100644 BLAS/DSTEQR.f delete mode 100644 BLAS/DSTERF.f delete mode 100644 BLAS/DSWAP.f delete mode 100644 BLAS/DTRSM.f delete mode 100644 BLAS/DTRTRI.f delete mode 100644 BLAS/ILAENV.f delete mode 100644 BLAS/LSAME.f delete mode 100644 BLAS/XERBLA.f delete mode 100644 Source/Modules/LAPACK/LAPACK_BLAS_AUX.f delete mode 100644 Source/Modules/LAPACK/LAPACK_GIV_MGIV_EIG.f delete mode 100644 Source/Modules/LAPACK/LAPACK_LANCZOS_EIG.f delete mode 100644 Source/Modules/LAPACK/LAPACK_LIN_EQN_DGB.f delete mode 100644 Source/Modules/LAPACK/LAPACK_LIN_EQN_DGE.f delete mode 100644 Source/Modules/LAPACK/LAPACK_LIN_EQN_DPB.f delete mode 100644 Source/Modules/LAPACK/LAPACK_MISCEL.f delete mode 100644 Source/Modules/LAPACK/LAPACK_STD_EIG_1.f delete mode 100644 Source/Modules/LAPACK/LAPACK_SYM_MAT_INV.f create mode 100644 Source/Modules/MYSTRAN_LAPACK_EXT/MYSTRAN_LAPACK_EXT.f90 create mode 160000 Source/lapack create mode 100644 build/CPackConfig.cmake create mode 100644 build/CPackSourceConfig.cmake create mode 100644 build/superlu/FORTRAN/superlu_config.h create mode 100644 build/superlu/SRC/superluConfig.cmake create mode 100644 build/superlu/SRC/superluConfigVersion.cmake create mode 100644 build/superlu/SRC/superluTargets.cmake create mode 100644 build/superlu/SRC/superlu_config.h create mode 100644 build/superlu/superlu.pc delete mode 100644 dev_docs/lapack_unification_prompt.md diff --git a/.gitmodules b/.gitmodules index 42221b77..7f0360e0 100644 --- a/.gitmodules +++ b/.gitmodules @@ -23,3 +23,6 @@ ignore = all update = checkout branch = master +[submodule "Source/lapack"] + path = Source/lapack + url = https://github.com/Reference-LAPACK/lapack.git diff --git a/BLAS/DGEMM.f b/BLAS/DGEMM.f deleted file mode 100644 index 4f4af89e..00000000 --- a/BLAS/DGEMM.f +++ /dev/null @@ -1,324 +0,0 @@ -! 006 LAPACK_BLAS_AUX ############################################################################################################## - - SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - - USE OUTA_HERE_Interface - -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - REAL(DOUBLE) ALPHA, BETA -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), B( LDB, * ), C( LDC, * ) - - LOGICAL LSAME - EXTERNAL LSAME -* .. -* -* Purpose -* ======= -* -* DGEMM performs one of the matrix-matrix operations -* -* C := alpha*op( A )*op( B ) + beta*C, -* -* where op( X ) is one of -* -* op( X ) = X or op( X ) = X', -* -* alpha and beta are scalars, and A, B and C are matrices, with op( A ) -* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -* -* Parameters -* ========== -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n', op( A ) = A. -* -* TRANSA = 'T' or 't', op( A ) = A'. -* -* TRANSA = 'C' or 'c', op( A ) = A'. -* -* Unchanged on exit. -* -* TRANSB - CHARACTER*1. -* On entry, TRANSB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANSB = 'N' or 'n', op( B ) = B. -* -* TRANSB = 'T' or 't', op( B ) = B'. -* -* TRANSB = 'C' or 'c', op( B ) = B'. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix -* op( A ) and of the matrix C. M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix -* op( B ) and the number of columns of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of columns of the matrix -* op( A ) and the number of rows of the matrix op( B ). K must -* be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, ka ), where ka is -* k when TRANSA = 'N' or 'n', and is m otherwise. -* Before entry with TRANSA = 'N' or 'n', the leading m by k -* part of the array A must contain the matrix A, otherwise -* the leading k by m part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANSA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - REAL(DOUBLE) array of DIMENSION ( LDB, kb ), where kb is -* n when TRANSB = 'N' or 'n', and is k otherwise. -* Before entry with TRANSB = 'N' or 'n', the leading k by n -* part of the array B must contain the matrix B, otherwise -* the leading n by k part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANSB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - REAL(DOUBLE). -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - REAL(DOUBLE) array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n matrix -* ( alpha*op( A )*op( B ) + beta*C ). -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - REAL(DOUBLE) TEMP -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA, NCOLA and NROWB as the number of rows -* and columns of A and the number of rows of B respectively. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And if alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF( NOTA )THEN -* -* Form C := alpha*A*B' + beta*C -* - DO 170, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 130, I = 1, M - C( I, J ) = ZERO - 130 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 140, I = 1, M - C( I, J ) = BETA*C( I, J ) - 140 CONTINUE - END IF - DO 160, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 200, J = 1, N - DO 190, I = 1, M - TEMP = ZERO - DO 180, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 180 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END SUBROUTINE DGEMM - diff --git a/BLAS/DGEMV.f b/BLAS/DGEMV.f deleted file mode 100644 index 9da670dd..00000000 --- a/BLAS/DGEMV.f +++ /dev/null @@ -1,272 +0,0 @@ -! 007 LAPACK_BLAS_AUX ############################################################################################################## - - SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - - USE OUTA_HERE_Interface - -* .. Scalar Arguments .. - REAL(DOUBLE) ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL(DOUBLE). -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - REAL(DOUBLE) array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - DO 110, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END SUBROUTINE DGEMV - diff --git a/BLAS/DLAMCH.f b/BLAS/DLAMCH.f deleted file mode 100644 index 07d9778e..00000000 --- a/BLAS/DLAMCH.f +++ /dev/null @@ -1,138 +0,0 @@ -! 031 LAPACK_BLAS_AUX ############################################################################################################## - - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - USE LAPACK_BLAS_AUX - - USE OUTA_HERE_Interface - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* DLAMCH determines REAL(DOUBLE) machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by DLAMCH: -* = 'E' or 'e', DLAMCH := eps -* = 'S' or 's , DLAMCH := sfmin -* = 'B' or 'b', DLAMCH := base -* = 'P' or 'p', DLAMCH := eps*base -* = 'N' or 'n', DLAMCH := t -* = 'R' or 'r', DLAMCH := rnd -* = 'M' or 'm', DLAMCH := emin -* = 'U' or 'u', DLAMCH := rmin -* = 'L' or 'l', DLAMCH := emax -* = 'O' or 'o', DLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST, LRND - INTEGER BETA, IMAX, IMIN, IT - REAL(DOUBLE) BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, - $ RND, SFMIN, SMALL, T -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Save statement .. - SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, - $ EMAX, RMAX, PREC -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) - BASE = BETA - T = IT - IF( LRND ) THEN - RND = ONE - EPS = ( BASE**( 1-IT ) ) / 2 - ELSE - RND = ZERO - EPS = BASE**( 1-IT ) - END IF - PREC = EPS*BASE - EMIN = IMIN - EMAX = IMAX - SFMIN = RMIN - SMALL = ONE / RMAX - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = BASE - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = PREC - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = T - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = EMIN - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = RMIN - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = EMAX - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = RMAX - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END FUNCTION DLAMCH -* diff --git a/BLAS/DLANST.f b/BLAS/DLANST.f deleted file mode 100644 index c3fe41ae..00000000 --- a/BLAS/DLANST.f +++ /dev/null @@ -1,136 +0,0 @@ -! 038 LAPACK_BLAS_AUX ############################################################################################################## - - DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - USE LAPACK_BLAS_AUX - - USE OUTA_HERE_Interface -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER N -* .. -* .. Array Arguments .. - REAL(DOUBLE) D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DLANST returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* real symmetric tridiagonal matrix A. -* -* Description -* =========== -* -* DLANST returns the value -* -* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in DLANST as described -* above. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. When N = 0, DLANST is -* set to zero. -* -* D (input) REAL(DOUBLE) array, dimension (N) -* The diagonal elements of A. -* -* E (input) REAL(DOUBLE) array, dimension (N-1) -* The (n-1) sub-diagonal or super-diagonal elements of A. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I - REAL(DOUBLE) ANORM, SCALE, SUM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - IF( N.LE.0 ) THEN - ANORM = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - ANORM = ABS( D( N ) ) - DO 10 I = 1, N - 1 - ANORM = MAX( ANORM, ABS( D( I ) ) ) - ANORM = MAX( ANORM, ABS( E( I ) ) ) - 10 CONTINUE - ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. - $ LSAME( NORM, 'I' ) ) THEN -* -* Find norm1(A). -* - IF( N.EQ.1 ) THEN - ANORM = ABS( D( 1 ) ) - ELSE - ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), - $ ABS( E( N-1 ) )+ABS( D( N ) ) ) - DO 20 I = 2, N - 1 - ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ - $ ABS( E( I-1 ) ) ) - 20 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( N.GT.1 ) THEN - CALL DLASSQ( N-1, E, 1, SCALE, SUM ) - SUM = 2*SUM - END IF - CALL DLASSQ( N, D, 1, SCALE, SUM ) - ANORM = SCALE*SQRT( SUM ) - END IF -* - DLANST = ANORM - RETURN -* -* End of DLANST -* - END FUNCTION DLANST - diff --git a/BLAS/DSCAL.f b/BLAS/DSCAL.f deleted file mode 100644 index b1baaaf4..00000000 --- a/BLAS/DSCAL.f +++ /dev/null @@ -1,56 +0,0 @@ -! 012 LAPACK_BLAS_AUX ############################################################################################################## - - SUBROUTINE DSCAL(N,DA,DX,INCX) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - - USE OUTA_HERE_Interface - -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL(DOUBLE) da,dx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dx(i) = da*dx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dx(i) = da*dx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dx(i) = da*dx(i) - dx(i + 1) = da*dx(i + 1) - dx(i + 2) = da*dx(i + 2) - dx(i + 3) = da*dx(i + 3) - dx(i + 4) = da*dx(i + 4) - 50 continue - return - - END SUBROUTINE DSCAL - diff --git a/BLAS/DSTEQR.f b/BLAS/DSTEQR.f deleted file mode 100644 index 4bce899e..00000000 --- a/BLAS/DSTEQR.f +++ /dev/null @@ -1,516 +0,0 @@ -! 002 LAPACK_MISCEL ################################################################################################################ - - SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : FATAL_ERR - USE LAPACK_BLAS_AUX - - USE OUTA_HERE_Interface - -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) D( * ), E( * ), WORK( * ), Z( LDZ, * ) - -* .. -* -* Purpose -* ======= -* -* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a -* symmetric tridiagonal matrix using the implicit QL or QR method. -* The eigenvectors of a full or band symmetric matrix can also be found -* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to -* tridiagonal form. -* -* Arguments -* ========= -* -* COMPZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only. -* = 'V': Compute eigenvalues and eigenvectors of the original -* symmetric matrix. On entry, Z must contain the -* orthogonal matrix used to reduce the original matrix -* to tridiagonal form. -* = 'I': Compute eigenvalues and eigenvectors of the -* tridiagonal matrix. Z is initialized to the identity -* matrix. -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input/output) REAL(DOUBLE) array, dimension (N) -* On entry, the diagonal elements of the tridiagonal matrix. -* On exit, if INFO = 0, the eigenvalues in ascending order. -* -* E (input/output) REAL(DOUBLE) array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix. -* On exit, E has been destroyed. -* -* Z (input/output) REAL(DOUBLE) array, dimension (LDZ, N) -* On entry, if COMPZ = 'V', then Z contains the orthogonal -* matrix used in the reduction to tridiagonal form. -* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the -* orthonormal eigenvectors of the original symmetric matrix, -* and if COMPZ = 'I', Z contains the orthonormal eigenvectors -* of the symmetric tridiagonal matrix. -* If COMPZ = 'N', then Z is not referenced. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* eigenvectors are desired, then LDZ >= max(1,N). -* -* WORK (workspace) REAL(DOUBLE) array, dimension (max(1,2*N-2)) -* If COMPZ = 'N', then WORK is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm has failed to find all the eigenvalues in -* a total of 30*N iterations; if INFO = i, then i -* elements of E have not converged to zero; on exit, D -* and E contain the elements of a symmetric tridiagonal -* matrix which is orthogonally similar to the original -* matrix. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, - $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, - $ NM1, NMAXIT - REAL(DOUBLE) ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, - $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT - - REAL(DOUBLE) DLAMCH, DLANST - EXTERNAL DLAMCH, DLANST -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - INFO = 0 -* - IF( LSAME( COMPZ, 'N' ) ) THEN - ICOMPZ = 0 - ELSE IF( LSAME( COMPZ, 'V' ) ) THEN - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ICOMPZ = 2 - ELSE - ICOMPZ = -1 - END IF - IF( ICOMPZ.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, - $ N ) ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( ICOMPZ.EQ.2 ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* Determine the unit roundoff and over/underflow thresholds. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues and eigenvectors of the tridiagonal -* matrix. -* - IF( ICOMPZ.EQ.2 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -* - NMAXIT = N*MAXIT - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 - NM1 = N - 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 160 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - IF( L1.LE.NM1 ) THEN - DO 20 M = L1, NM1 - TST = ABS( E( M ) ) - IF( TST.EQ.ZERO ) - $ GO TO 30 - IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - END IF - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.EQ.ZERO ) - $ GO TO 10 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GT.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 40 CONTINUE - IF( L.NE.LEND ) THEN - LENDM1 = LEND - 1 - DO 50 M = L, LENDM1 - TST = ABS( E( M ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ - $ SAFMIN )GO TO 60 - 50 CONTINUE - END IF -* - M = LEND -* - 60 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 80 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L+1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) - WORK( L ) = C - WORK( N-1+L ) = S - CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), - $ WORK( N-1+L ), Z( 1, L ), LDZ ) - ELSE - CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) - END IF - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L+1 )-P ) / ( TWO*E( L ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - MM1 = M - 1 - DO 70 I = MM1, L, -1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M-1 ) - $ E( I+1 ) = R - G = D( I+1 ) - P - R = ( D( I )-G )*S + TWO*C*B - P = S*R - D( I+1 ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = -S - END IF -* - 70 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = M - L + 1 - CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), - $ Z( 1, L ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( L ) = G - GO TO 40 -* -* Eigenvalue found. -* - 80 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 40 - GO TO 140 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 90 CONTINUE - IF( L.NE.LEND ) THEN - LENDP1 = LEND + 1 - DO 100 M = L, LENDP1, -1 - TST = ABS( E( M-1 ) )**2 - IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ - $ SAFMIN )GO TO 110 - 100 CONTINUE - END IF -* - M = LEND -* - 110 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 130 -* -* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 -* to compute its eigensystem. -* - IF( M.EQ.L-1 ) THEN - IF( ICOMPZ.GT.0 ) THEN - CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) - WORK( M ) = C - WORK( N-1+M ) = S - CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), - $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) - ELSE - CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) - END IF - D( L-1 ) = RT1 - D( L ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 140 - JTOT = JTOT + 1 -* -* Form shift. -* - G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) - R = DLAPY2( G, ONE ) - G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) -* - S = ONE - C = ONE - P = ZERO -* -* Inner loop -* - LM1 = L - 1 - DO 120 I = M, LM1 - F = S*E( I ) - B = C*E( I ) - CALL DLARTG( G, F, C, S, R ) - IF( I.NE.M ) - $ E( I-1 ) = R - G = D( I ) - P - R = ( D( I+1 )-G )*S + TWO*C*B - P = S*R - D( I ) = G + P - G = C*R - B -* -* If eigenvectors are desired, then save rotations. -* - IF( ICOMPZ.GT.0 ) THEN - WORK( I ) = C - WORK( N-1+I ) = S - END IF -* - 120 CONTINUE -* -* If eigenvectors are desired, then apply saved rotations. -* - IF( ICOMPZ.GT.0 ) THEN - MM = L - M + 1 - CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), - $ Z( 1, M ), LDZ ) - END IF -* - D( L ) = D( L ) - P - E( LM1 ) = G - GO TO 90 -* -* Eigenvalue found. -* - 130 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 90 - GO TO 140 -* - END IF -* -* Undo scaling if necessary -* - 140 CONTINUE - IF( ISCALE.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - ELSE IF( ISCALE.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), - $ N, INFO ) - END IF -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.LT.NMAXIT ) - $ GO TO 10 - DO 150 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 150 CONTINUE - GO TO 190 -* -* Order eigenvalues and eigenvectors. -* - 160 CONTINUE - IF( ICOMPZ.EQ.0 ) THEN -* -* Use Quick Sort -* - CALL DLASRT( 'I', N, D, INFO ) -* - ELSE -* -* Use Selection Sort to minimize swaps of eigenvectors -* - DO 180 II = 2, N - I = II - 1 - K = I - P = D( I ) - DO 170 J = II, N - IF( D( J ).LT.P ) THEN - K = J - P = D( J ) - END IF - 170 CONTINUE - IF( K.NE.I ) THEN - D( K ) = D( I ) - D( I ) = P - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) - END IF - 180 CONTINUE - END IF -* - 190 CONTINUE - - RETURN -* -* End of DSTEQR -* - END SUBROUTINE DSTEQR - diff --git a/BLAS/DSTERF.f b/BLAS/DSTERF.f deleted file mode 100644 index 35e1caba..00000000 --- a/BLAS/DSTERF.f +++ /dev/null @@ -1,376 +0,0 @@ -! 001 LAPACK_MISCEL ################################################################################################################ - - SUBROUTINE DSTERF( N, D, E, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - USE LAPACK_BLAS_AUX - USE LAPACK_LIN_EQN_DPB - -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix -* using the Pal-Walker-Kahan variant of the QL or QR algorithm. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input/output) REAL(DOUBLE) array, dimension (N) -* On entry, the n diagonal elements of the tridiagonal matrix. -* On exit, if INFO = 0, the eigenvalues in ascending order. -* -* E (input/output) REAL(DOUBLE) array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix. -* On exit, E has been destroyed. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm failed to find all of the eigenvalues in -* a total of 30*N iterations; if INFO = i, then i -* elements of E have not converged to zero. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) -* .. -* .. Local Scalars .. - INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, - $ NMAXIT - REAL(DOUBLE) ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, - $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, - $ SIGMA, SSFMAX, SSFMIN -* .. -* .. External Functions .. -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT - - REAL(DOUBLE) DLAMCH, DLANST - EXTERNAL DLAMCH, DLANST -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - INFO = 0 -* -* Quick return if possible -* - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DSTERF', -INFO ) - RETURN - END IF - IF( N.LE.1 ) - $ RETURN -* -* Determine the unit roundoff for this environment. -* - EPS = DLAMCH( 'E' ) - EPS2 = EPS**2 - SAFMIN = DLAMCH( 'S' ) - SAFMAX = ONE / SAFMIN - SSFMAX = SQRT( SAFMAX ) / THREE - SSFMIN = SQRT( SAFMIN ) / EPS2 -* -* Compute the eigenvalues of the tridiagonal matrix. -* - NMAXIT = N*MAXIT - SIGMA = ZERO - JTOT = 0 -* -* Determine where the matrix splits and choose QL or QR iteration -* for each block, according to whether top or bottom diagonal -* element is smaller. -* - L1 = 1 -* - 10 CONTINUE - IF( L1.GT.N ) - $ GO TO 170 - IF( L1.GT.1 ) - $ E( L1-1 ) = ZERO - DO 20 M = L1, N - 1 - IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ - $ 1 ) ) ) )*EPS ) THEN - E( M ) = ZERO - GO TO 30 - END IF - 20 CONTINUE - M = N -* - 30 CONTINUE - L = L1 - LSV = L - LEND = M - LENDSV = LEND - L1 = M + 1 - IF( LEND.EQ.L ) - $ GO TO 10 -* -* Scale submatrix in rows and columns L to LEND -* - ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) - ISCALE = 0 - IF( ANORM.GT.SSFMAX ) THEN - ISCALE = 1 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, - $ INFO ) - ELSE IF( ANORM.LT.SSFMIN ) THEN - ISCALE = 2 - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, - $ INFO ) - CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, - $ INFO ) - END IF -* - DO 40 I = L, LEND - 1 - E( I ) = E( I )**2 - 40 CONTINUE -* -* Choose between QL and QR iteration -* - IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN - LEND = LSV - L = LENDSV - END IF -* - IF( LEND.GE.L ) THEN -* -* QL Iteration -* -* Look for small subdiagonal element. -* - 50 CONTINUE - IF( L.NE.LEND ) THEN - DO 60 M = L, LEND - 1 - IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) - $ GO TO 70 - 60 CONTINUE - END IF - M = LEND -* - 70 CONTINUE - IF( M.LT.LEND ) - $ E( M ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 90 -* -* If remaining matrix is 2 by 2, use DLAE2 to compute its -* eigenvalues. -* - IF( M.EQ.L+1 ) THEN - RTE = SQRT( E( L ) ) - CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) - D( L ) = RT1 - D( L+1 ) = RT2 - E( L ) = ZERO - L = L + 2 - IF( L.LE.LEND ) - $ GO TO 50 - GO TO 150 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 150 - JTOT = JTOT + 1 -* -* Form shift. -* - RTE = SQRT( E( L ) ) - SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) - R = DLAPY2( SIGMA, ONE ) - SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) -* - C = ONE - S = ZERO - GAMMA = D( M ) - SIGMA - P = GAMMA*GAMMA -* -* Inner loop -* - DO 80 I = M - 1, L, -1 - BB = E( I ) - R = P + BB - IF( I.NE.M-1 ) - $ E( I+1 ) = S*R - OLDC = C - C = P / R - S = BB / R - OLDGAM = GAMMA - ALPHA = D( I ) - GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM - D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) - IF( C.NE.ZERO ) THEN - P = ( GAMMA*GAMMA ) / C - ELSE - P = OLDC*BB - END IF - 80 CONTINUE -* - E( L ) = S*P - D( L ) = SIGMA + GAMMA - GO TO 50 -* -* Eigenvalue found. -* - 90 CONTINUE - D( L ) = P -* - L = L + 1 - IF( L.LE.LEND ) - $ GO TO 50 - GO TO 150 -* - ELSE -* -* QR Iteration -* -* Look for small superdiagonal element. -* - 100 CONTINUE - DO 110 M = L, LEND + 1, -1 - IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) - $ GO TO 120 - 110 CONTINUE - M = LEND -* - 120 CONTINUE - IF( M.GT.LEND ) - $ E( M-1 ) = ZERO - P = D( L ) - IF( M.EQ.L ) - $ GO TO 140 -* -* If remaining matrix is 2 by 2, use DLAE2 to compute its -* eigenvalues. -* - IF( M.EQ.L-1 ) THEN - RTE = SQRT( E( L-1 ) ) - CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) - D( L ) = RT1 - D( L-1 ) = RT2 - E( L-1 ) = ZERO - L = L - 2 - IF( L.GE.LEND ) - $ GO TO 100 - GO TO 150 - END IF -* - IF( JTOT.EQ.NMAXIT ) - $ GO TO 150 - JTOT = JTOT + 1 -* -* Form shift. -* - RTE = SQRT( E( L-1 ) ) - SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) - R = DLAPY2( SIGMA, ONE ) - SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) -* - C = ONE - S = ZERO - GAMMA = D( M ) - SIGMA - P = GAMMA*GAMMA -* -* Inner loop -* - DO 130 I = M, L - 1 - BB = E( I ) - R = P + BB - IF( I.NE.M ) - $ E( I-1 ) = S*R - OLDC = C - C = P / R - S = BB / R - OLDGAM = GAMMA - ALPHA = D( I+1 ) - GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM - D( I ) = OLDGAM + ( ALPHA-GAMMA ) - IF( C.NE.ZERO ) THEN - P = ( GAMMA*GAMMA ) / C - ELSE - P = OLDC*BB - END IF - 130 CONTINUE -* - E( L-1 ) = S*P - D( L ) = SIGMA + GAMMA - GO TO 100 -* -* Eigenvalue found. -* - 140 CONTINUE - D( L ) = P -* - L = L - 1 - IF( L.GE.LEND ) - $ GO TO 100 - GO TO 150 -* - END IF -* -* Undo scaling if necessary -* - 150 CONTINUE - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) - IF( ISCALE.EQ.2 ) - $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, - $ D( LSV ), N, INFO ) -* -* Check for no convergence to an eigenvalue after a total -* of N*MAXIT iterations. -* - IF( JTOT.LT.NMAXIT ) - $ GO TO 10 - DO 160 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 160 CONTINUE - GO TO 180 -* -* Sort eigenvalues in increasing order. -* - 170 CONTINUE - CALL DLASRT( 'I', N, D, INFO ) -* - 180 CONTINUE - - RETURN -* -* End of DSTERF -* - END SUBROUTINE DSTERF - diff --git a/BLAS/DSWAP.f b/BLAS/DSWAP.f deleted file mode 100644 index 05803382..00000000 --- a/BLAS/DSWAP.f +++ /dev/null @@ -1,69 +0,0 @@ -! 013 LAPACK_BLAS_AUX ############################################################################################################## - - SUBROUTINE DSWAP (N,DX,INCX,DY,INCY) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - - USE OUTA_HERE_Interface - -c -c interchanges two vectors. -c uses unrolled loops for increments equal one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL(DOUBLE) dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dx(ix) - dx(ix) = dy(iy) - dy(iy) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,3 - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - dtemp = dx(i + 1) - dx(i + 1) = dy(i + 1) - dy(i + 1) = dtemp - dtemp = dx(i + 2) - dx(i + 2) = dy(i + 2) - dy(i + 2) = dtemp - 50 continue - return - - END SUBROUTINE DSWAP - diff --git a/BLAS/DTRSM.f b/BLAS/DTRSM.f deleted file mode 100644 index 64d35ae9..00000000 --- a/BLAS/DTRSM.f +++ /dev/null @@ -1,389 +0,0 @@ -! 022 LAPACK_BLAS_AUX ############################################################################################################## - - SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - - USE OUTA_HERE_Interface - -** .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - REAL(DOUBLE) ALPHA -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - REAL(DOUBLE) array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - REAL(DOUBLE) TEMP -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END SUBROUTINE DTRSM - diff --git a/BLAS/DTRTRI.f b/BLAS/DTRTRI.f deleted file mode 100644 index 94834410..00000000 --- a/BLAS/DTRTRI.f +++ /dev/null @@ -1,190 +0,0 @@ -! 004 LAPACK_SYM_MAT_INV ########################################################################################################### - - SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE SCONTR, ONLY : BLNK_SUB_NAM - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & TSEC - USE LAPACK_BLAS_AUX - USE LAPACK_SYM_MAT_INV - - USE OURTIM_Interface - - -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTRI computes the inverse of a real upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of DTRTRI -* - END SUBROUTINE DTRTRI - diff --git a/BLAS/ILAENV.f b/BLAS/ILAENV.f deleted file mode 100644 index 5bf60286..00000000 --- a/BLAS/ILAENV.f +++ /dev/null @@ -1,549 +0,0 @@ -! 066 LAPACK_BLAS_AUX ############################################################################################################## - - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, - $ N4 ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - - USE OUTA_HERE_Interface - -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR and QZ methods -* for nonsymmetric eigenvalue problems. -* = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* =10: ieee NaN arithmetic can be trusted not to trap -* =11: infinity arithmetic can be trusted not to trap -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* (ILAENV) (output) INTEGER -* >= 0: the value of the parameter specified by ISPEC -* < 0: if ILAENV = -k, the k-th argument had an illegal value. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for STRTRI as follows: -* -* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1 - CHARACTER*2 C2, C4 - CHARACTER*3 C3 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. -* .. -* .. Executable Statements .. -* - GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, - $ 1100 ) ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 100 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1:1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 10 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1:1 ) = CHAR( IC+64 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) - $ SUBNAM( I:I ) = CHAR( IC+64 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1:1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2:3 ) - C3 = SUBNAM( 4:6 ) - C4 = C3( 2:3 ) -* - GO TO ( 110, 200, 300 ) ISPEC -* - 110 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or REAL(DOUBLE). -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 200 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 300 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 400 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 500 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 600 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 700 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 800 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 900 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 1000 CONTINUE -* -* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap -* - ILAENV = 0 - RETURN -* - 1100 CONTINUE -* -* ISPEC = 11: infinity arithmetic can be trusted not to trap -* - ILAENV = 0 - RETURN -* -* End of ILAENV -* - END FUNCTION ILAENV - diff --git a/BLAS/LSAME.f b/BLAS/LSAME.f deleted file mode 100644 index b57065ba..00000000 --- a/BLAS/LSAME.f +++ /dev/null @@ -1,90 +0,0 @@ -! 067 LAPACK_BLAS_AUX ############################################################################################################## - - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* Test if the characters are equal -* - LSAME = CA.EQ.CB - IF( LSAME ) - $ RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR( 'Z' ) -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR( CA ) - INTB = ICHAR( CB ) -* - IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 - IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* - ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.129 .AND. INTA.LE.137 .OR. - $ INTA.GE.145 .AND. INTA.LE.153 .OR. - $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 - IF( INTB.GE.129 .AND. INTB.LE.137 .OR. - $ INTB.GE.145 .AND. INTB.LE.153 .OR. - $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 -* - ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 - IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 - END IF - LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* - END FUNCTION LSAME - diff --git a/BLAS/XERBLA.f b/BLAS/XERBLA.f deleted file mode 100644 index 98ac88d8..00000000 --- a/BLAS/XERBLA.f +++ /dev/null @@ -1,59 +0,0 @@ -! 068 LAPACK_BLAS_AUX ############################################################################################################## - - SUBROUTINE XERBLA( SRNAME, arg_num ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - - USE OUTA_HERE_Interface - -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER*6 SRNAME - INTEGER arg_num -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* ===================================================================== -* -* .. Executable Statements .. -* - WRITE(ERR,800) SRNAME, arg_num - WRITE(F06,800) SRNAME, arg_num - FATAL_ERR = FATAL_ERR + 1 - CALL OUTA_HERE ( 'Y' ) -* - 800 FORMAT(' *ERROR 800: PROGRAMMING ERROR IN SUBROUTINE ',A - $ ,/,14X,' PARAMETER NUMBER ',I2,' HAD AN ILLEGAL VALUE') -* -* End of XERBLA -* - END SUBROUTINE XERBLA - diff --git a/BUILD.md b/BUILD.md index 1d16173a..05301c77 100644 --- a/BUILD.md +++ b/BUILD.md @@ -162,39 +162,39 @@ and run the appropriate `cmake` command again. --- -### "I'm getting cryptic linker errors related to BLAS!" - -MYSTRAN and SuperLU both need BLAS. The build system picks one of -three providers via the `MYSTRAN_BLAS` CMake option: - - - **`AUTO`** (default): try to locate a system BLAS (we recommend - OpenBLAS); if it isn't found, fall back to the bundled reference - routines. - - **`SYSTEM`**: require system BLAS; configuration fails with a - clear error if it cannot be found. - - **`EMBEDDED`**: ignore the system entirely and always compile in - MYSTRAN's bundled reference BLAS plus SuperLU's CBLAS. - -If the auto-detection picks up a BLAS that does not ship a static +### "I'm getting cryptic linker errors related to BLAS or LAPACK!" + +MYSTRAN and SuperLU both need BLAS and LAPACK. The build system +picks one of three providers via the `MYSTRAN_BLAS_LAPACK` CMake +option: + + - **`AUTO`** (default): try to locate a system BLAS and LAPACK (we + recommend OpenBLAS); if either isn't found, fall back to the + bundled Reference-LAPACK submodule. + - **`SYSTEM`**: require system BLAS and LAPACK; configuration + fails with a clear error if either cannot be found. + - **`EMBEDDED`**: ignore the system entirely and always build the + bundled Reference-LAPACK submodule (`Source/lapack/`), which + provides both BLAS and LAPACK. + +If the auto-detection picks up libraries that do not ship a static `.a` archive (a common Windows situation), re-run CMake with -`-DMYSTRAN_BLAS=EMBEDDED` to force the bundled fallback. +`-DMYSTRAN_BLAS_LAPACK=EMBEDDED` to force the bundled fallback. On Windows we ship fully static binaries, so when requesting `SYSTEM` mode you must have a static OpenBLAS available (MSYS2 / MinGW64: `pacman -S mingw-w64-x86_64-openblas`). -The legacy `-Denable_internal_blaslib=YES` flag still works; it is -mapped to `-DMYSTRAN_BLAS=EMBEDDED` with a deprecation warning. - -LAPACK is always provided by MYSTRAN's bundled reference -implementation under `Source/Modules/LAPACK/`; system LAPACK is not -yet supported. (See `dev_docs/lapack_unification_prompt.md` for the -follow-up effort.) +The legacy `-Denable_internal_blaslib=YES` and `-DMYSTRAN_BLAS=...` +flags still work; they are mapped to `MYSTRAN_BLAS_LAPACK` with a +deprecation warning. -Please be aware that the bundled reference BLAS is considerably -slower than a tuned implementation like OpenBLAS or MKL. That can -have a significant impact on the time it takes to run larger -models. +The bundled Reference-LAPACK is considerably slower than a tuned +implementation like OpenBLAS or MKL. That can have a significant +impact on the time it takes to run larger models. A small set of +mathematically-deviated routines (kept in +`Source/Modules/MYSTRAN_LAPACK_EXT/`) is always compiled into +MYSTRAN regardless of which provider is selected. --- diff --git a/CMakeLists.txt b/CMakeLists.txt index 8f7171d6..05cf2714 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -15,7 +15,6 @@ endif() # basic compiler and output options set(CMAKE_SOURCE_DIR "${PROJECT_SOURCE_DIR}/Source") -set(BLAS_SOURCE_DIR "${PROJECT_SOURCE_DIR}/BLAS") set(PROJECT_BINARY_DIR "${PROJECT_SOURCE_DIR}/Binaries") set(CMAKE_FLAGS "-c -fbacktrace") @@ -174,27 +173,31 @@ set(enable_tests OFF FORCE) set(enable_doc OFF FORCE) # ----------------------------------------------------------------------- -# BLAS provider resolution +# BLAS / LAPACK provider resolution # -# Single user-facing knob `MYSTRAN_BLAS` with three values: -# AUTO (default) - try system BLAS; fall back to embedded -# SYSTEM - require system BLAS; FATAL_ERROR if missing -# EMBEDDED - always use the bundled reference routines +# Single user-facing knob `MYSTRAN_BLAS_LAPACK` with three values: +# AUTO (default) - try system BLAS+LAPACK; fall back to building +# Reference-LAPACK from the bundled submodule +# SYSTEM - require system BLAS+LAPACK; FATAL_ERROR if missing +# EMBEDDED - always build Reference-LAPACK + its reference BLAS +# from the Source/lapack submodule # # The mode is resolved here, BEFORE add_subdirectory() for SuperLU / # SuperLU_MT, so we can forward the result to those subprojects via # `TPL_BLAS_LIBRARIES` and `enable_internal_blaslib` and avoid duplicate # symbols when statically linking on Windows (no symbol interposition). # -# LAPACK is currently always embedded (Source/Modules/LAPACK/*.f). A -# follow-up effort will let SYSTEM mode also use a system LAPACK; see -# dev_docs/lapack_unification_prompt.md. +# This replaces the older `MYSTRAN_BLAS` knob (which only governed BLAS, +# while LAPACK was always embedded under Source/Modules/LAPACK/*.f). The +# embedded LAPACK tree has been deleted; MYSTRAN now always links a real +# BLAS+LAPACK provider, and the only remaining MYSTRAN-specific routines +# (the handful of mathematically modified ones) live in +# Source/Modules/MYSTRAN_LAPACK_EXT/. # ----------------------------------------------------------------------- -# Backwards-compat: legacy `-Denable_internal_blaslib=...` maps to the new -# variable on first configure. We use an internal sentinel so the warning -# only fires when the user explicitly passed it on the command line. -if(DEFINED enable_internal_blaslib AND NOT _MYSTRAN_BLAS_LEGACY_MAPPED) +# Backwards-compat: legacy `-Denable_internal_blaslib=...` and +# `-DMYSTRAN_BLAS=...` map to the new variable on first configure. +if(DEFINED enable_internal_blaslib AND NOT _MYSTRAN_BLAS_LAPACK_LEGACY_MAPPED) if(enable_internal_blaslib) set(_LEGACY_MODE "EMBEDDED") else() @@ -203,25 +206,34 @@ if(DEFINED enable_internal_blaslib AND NOT _MYSTRAN_BLAS_LEGACY_MAPPED) message(DEPRECATION "'enable_internal_blaslib' is deprecated; " - "use -DMYSTRAN_BLAS=${_LEGACY_MODE} instead.") - set(MYSTRAN_BLAS "${_LEGACY_MODE}" - CACHE STRING "BLAS provider: AUTO, SYSTEM, or EMBEDDED" FORCE) - set(_MYSTRAN_BLAS_LEGACY_MAPPED TRUE CACHE INTERNAL "") + "use -DMYSTRAN_BLAS_LAPACK=${_LEGACY_MODE} instead.") + set(MYSTRAN_BLAS_LAPACK "${_LEGACY_MODE}" + CACHE STRING "BLAS+LAPACK provider: AUTO, SYSTEM, or EMBEDDED" FORCE) + set(_MYSTRAN_BLAS_LAPACK_LEGACY_MAPPED TRUE CACHE INTERNAL "") endif() -set(MYSTRAN_BLAS "AUTO" - CACHE STRING "BLAS provider: AUTO, SYSTEM, or EMBEDDED") -set_property(CACHE MYSTRAN_BLAS PROPERTY STRINGS AUTO SYSTEM EMBEDDED) +if(DEFINED MYSTRAN_BLAS AND NOT _MYSTRAN_BLAS_LAPACK_LEGACY_MAPPED) + message(DEPRECATION + "'MYSTRAN_BLAS' is deprecated; " + "use -DMYSTRAN_BLAS_LAPACK=${MYSTRAN_BLAS} instead.") + set(MYSTRAN_BLAS_LAPACK "${MYSTRAN_BLAS}" + CACHE STRING "BLAS+LAPACK provider: AUTO, SYSTEM, or EMBEDDED" FORCE) + set(_MYSTRAN_BLAS_LAPACK_LEGACY_MAPPED TRUE CACHE INTERNAL "") +endif() -if(NOT MYSTRAN_BLAS MATCHES "^(AUTO|SYSTEM|EMBEDDED)$") +set(MYSTRAN_BLAS_LAPACK "AUTO" + CACHE STRING "BLAS+LAPACK provider: AUTO, SYSTEM, or EMBEDDED") +set_property(CACHE MYSTRAN_BLAS_LAPACK PROPERTY STRINGS AUTO SYSTEM EMBEDDED) + +if(NOT MYSTRAN_BLAS_LAPACK MATCHES "^(AUTO|SYSTEM|EMBEDDED)$") message(FATAL_ERROR - "MYSTRAN_BLAS must be AUTO, SYSTEM, or EMBEDDED " - "(got '${MYSTRAN_BLAS}').") + "MYSTRAN_BLAS_LAPACK must be AUTO, SYSTEM, or EMBEDDED " + "(got '${MYSTRAN_BLAS_LAPACK}').") endif() -set(_MYSTRAN_HAVE_SYSTEM_BLAS FALSE) +set(_MYSTRAN_HAVE_SYSTEM_BLAS_LAPACK FALSE) -if(NOT MYSTRAN_BLAS STREQUAL "EMBEDDED") +if(NOT MYSTRAN_BLAS_LAPACK STREQUAL "EMBEDDED") if(TPL_BLAS_LIBRARIES) set(BLAS_FOUND TRUE) set(BLAS_LIBRARIES "${TPL_BLAS_LIBRARIES}") @@ -230,44 +242,87 @@ if(NOT MYSTRAN_BLAS STREQUAL "EMBEDDED") endif() if(BLAS_FOUND) - set(_MYSTRAN_HAVE_SYSTEM_BLAS TRUE) + find_package(LAPACK QUIET) + endif() + + if(BLAS_FOUND AND LAPACK_FOUND) + set(_MYSTRAN_HAVE_SYSTEM_BLAS_LAPACK TRUE) endif() endif() -if(MYSTRAN_BLAS STREQUAL "SYSTEM" AND NOT _MYSTRAN_HAVE_SYSTEM_BLAS) +if(MYSTRAN_BLAS_LAPACK STREQUAL "SYSTEM" AND NOT _MYSTRAN_HAVE_SYSTEM_BLAS_LAPACK) message(FATAL_ERROR - "MYSTRAN_BLAS=SYSTEM was requested but a system BLAS could not be " - "located.\n" + "MYSTRAN_BLAS_LAPACK=SYSTEM was requested but a system BLAS+LAPACK " + "could not be located.\n" "Install OpenBLAS (Debian/Ubuntu: 'libopenblas-dev'; " "MSYS2/MinGW64: 'mingw-w64-x86_64-openblas') or set TPL_BLAS_LIBRARIES " - "manually. Use -DMYSTRAN_BLAS=EMBEDDED to fall back to the bundled " - "reference routines.") + "manually. Use -DMYSTRAN_BLAS_LAPACK=EMBEDDED to build the bundled " + "Reference-LAPACK submodule instead.") endif() -if(_MYSTRAN_HAVE_SYSTEM_BLAS) - set(_MYSTRAN_BLAS_MODE "SYSTEM") +if(_MYSTRAN_HAVE_SYSTEM_BLAS_LAPACK) + set(_MYSTRAN_BLAS_LAPACK_MODE "SYSTEM") else() - set(_MYSTRAN_BLAS_MODE "EMBEDDED") + set(_MYSTRAN_BLAS_LAPACK_MODE "EMBEDDED") +endif() + +# In EMBEDDED mode, build Reference-LAPACK (BLAS + LAPACK) from the +# submodule under Source/lapack. Configure it as a quiet, minimal, +# static-only sub-build before any add_subdirectory() that consumes it. +if(_MYSTRAN_BLAS_LAPACK_MODE STREQUAL "EMBEDDED") + set(MYSTRAN_LAPACK_DIR "${PROJECT_SOURCE_DIR}/Source/lapack") + + if(NOT EXISTS "${MYSTRAN_LAPACK_DIR}/CMakeLists.txt") + message(FATAL_ERROR + "The Reference-LAPACK submodule was not downloaded. " + "Run: git submodule update --init --recursive") + endif() + + # Only build what MYSTRAN actually uses: double-precision real BLAS + # and LAPACK. Everything else off. + set(BUILD_SHARED_LIBS OFF CACHE BOOL "" FORCE) + set(BUILD_TESTING OFF CACHE BOOL "" FORCE) + set(BUILD_DEPRECATED OFF CACHE BOOL "" FORCE) + set(BUILD_SINGLE OFF CACHE BOOL "" FORCE) + set(BUILD_DOUBLE ON CACHE BOOL "" FORCE) + set(BUILD_COMPLEX OFF CACHE BOOL "" FORCE) + set(BUILD_COMPLEX16 OFF CACHE BOOL "" FORCE) + set(LAPACKE OFF CACHE BOOL "" FORCE) + set(CBLAS OFF CACHE BOOL "" FORCE) + set(USE_OPTIMIZED_BLAS OFF CACHE BOOL "" FORCE) + set(USE_OPTIMIZED_LAPACK OFF CACHE BOOL "" FORCE) + + add_subdirectory("${MYSTRAN_LAPACK_DIR}" "${PROJECT_BINARY_DIR}/lapack" EXCLUDE_FROM_ALL) + + set(BLAS_LIBRARIES "blas" CACHE STRING "" FORCE) + set(LAPACK_LIBRARIES "lapack" CACHE STRING "" FORCE) endif() # Forward the resolution to SuperLU / SuperLU_MT subprojects. They read # `enable_internal_blaslib`, `TPL_ENABLE_INTERNAL_BLASLIB`, and # `TPL_BLAS_LIBRARIES` to decide whether to build their bundled CBLAS. -if(_MYSTRAN_BLAS_MODE STREQUAL "SYSTEM") +if(_MYSTRAN_BLAS_LAPACK_MODE STREQUAL "SYSTEM") set(TPL_BLAS_LIBRARIES "${BLAS_LIBRARIES}" CACHE FILEPATH "Set from MYSTRAN BLAS resolution." FORCE) set(enable_internal_blaslib OFF CACHE BOOL "Use system BLAS for SuperLU" FORCE) set(TPL_ENABLE_INTERNAL_BLASLIB OFF CACHE BOOL "Use system BLAS for SuperLU" FORCE) - message(STATUS "MYSTRAN BLAS mode: SYSTEM (${BLAS_LIBRARIES})") + message(STATUS + "MYSTRAN BLAS+LAPACK mode: SYSTEM (BLAS=${BLAS_LIBRARIES}, LAPACK=${LAPACK_LIBRARIES})") else() - set(enable_internal_blaslib ON - CACHE BOOL "Build internal CBLAS for SuperLU" FORCE) - set(TPL_ENABLE_INTERNAL_BLASLIB ON - CACHE BOOL "Build internal CBLAS for SuperLU" FORCE) + # Embedded mode: SuperLU links the Reference-LAPACK `blas` target + # (Fortran BLAS only). SuperLU's bundled CBLAS shim is no longer + # needed because Reference-LAPACK's blas archive provides every BLAS + # symbol SuperLU references. + set(enable_internal_blaslib OFF + CACHE BOOL "Use embedded Reference-LAPACK BLAS for SuperLU" FORCE) + set(TPL_ENABLE_INTERNAL_BLASLIB OFF + CACHE BOOL "Use embedded Reference-LAPACK BLAS for SuperLU" FORCE) + set(TPL_BLAS_LIBRARIES "blas" + CACHE STRING "Set from MYSTRAN BLAS resolution." FORCE) message(STATUS - "MYSTRAN BLAS mode: EMBEDDED (bundled reference routines)") + "MYSTRAN BLAS+LAPACK mode: EMBEDDED (Reference-LAPACK submodule)") endif() if(USE_SUPERLU_MT) @@ -443,52 +498,10 @@ file(GLOB_RECURSE ALL_FORTRAN_FILES "${CMAKE_SOURCE_DIR}/*.F03" ) -# Resolve BLAS linkage for the mystran target. The provider -# (SYSTEM vs EMBEDDED) was decided up top; here we only act on it. -if(_MYSTRAN_BLAS_MODE STREQUAL "EMBEDDED") - message(STATUS "Probing for missing BLAS routines to bundle locally") - list( - APPEND blas_fns dgemm dgemv dlamch dlanst dscal dsteqr dsterf dswap dtrsm - dtrtri ilaenv lsame xerbla - ) - - foreach(fname IN LISTS blas_fns) - set(CMAKE_REQUIRED_QUIET TRUE) - check_function_exists("${fname}" BLAS_FN_EXISTS) - unset(CMAKE_REQUIRED_QUIET) - set(BLAS_FN_EXISTS CACHE "1" STRING) - - if(NOT BLAS_FN_EXISTS) - string(TOUPPER ${fname} fname_upper) - list(APPEND missing_blas_src "${BLAS_SOURCE_DIR}/${fname_upper}.f") - list(APPEND missing_blas_fns ${fname}) - endif() - - unset(BLAS_FN_EXISTS CACHE) - endforeach() - - list(LENGTH missing_blas_fns MISSING_FNS_TOTAL) - - if(MISSING_FNS_TOTAL GREATER 0) - if(MISSING_FNS_TOTAL GREATER 1) - message( - STATUS - "BLAS subrs (${missing_blas_fns}) are absent and will be built locally." - ) - else() - message( - STATUS - "BLAS subr ${missing_blas_fns} is absent and will be built locally." - ) - endif() - endif() -else() - # SYSTEM mode: do not bundle any BLAS reference routines. The embedded - # LAPACK modules under Source/Modules/LAPACK still build (their public - # names are module-mangled and do not collide with system LAPACK). - set(missing_blas_src "") - set(MISSING_FNS_TOTAL 0) -endif() +# Exclude the Reference-LAPACK submodule from the mystran source list. +# Its Fortran files live under Source/lapack/ but are compiled by the +# submodule's own CMake project (when EMBEDDED), not by mystran. +list(FILTER ALL_FORTRAN_FILES EXCLUDE REGEX "${CMAKE_SOURCE_DIR}/lapack/") # prepare the main executable, linked against the specifics and the m # it appears utils used to be a module, but that is no longer the case? @@ -498,7 +511,6 @@ add_executable( mystran ${ALL_FORTRAN_FILES} ${SLU_DRIVER} - ${missing_blas_src} ) # determine which superlu variant to link against @@ -519,11 +531,9 @@ else() target_link_libraries(mystran superlu f2c) endif() -# In SYSTEM mode, link the system BLAS after the SuperLU/f2c libraries -# so unresolved BLAS calls from those archives also get satisfied. -if(_MYSTRAN_BLAS_MODE STREQUAL "SYSTEM") - target_link_libraries(mystran ${BLAS_LIBRARIES}) -endif() +# Link LAPACK first, then BLAS: LAPACK depends on BLAS so the linker +# must see BLAS symbols last when resolving LAPACK references. +target_link_libraries(mystran ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) set_target_properties( mystran PROPERTIES RUNTIME_OUTPUT_DIRECTORY ${PROJECT_BINARY_DIR} @@ -592,11 +602,13 @@ if(TPL_ENABLE_METISLIB) endif() endif() -# Local BLAS functions are compiled directly into the binary when the -# system does not provide them; treat them as a bundled static object -if(MISSING_FNS_TOTAL GREATER 0) +# In EMBEDDED mode, the Reference-LAPACK submodule provides static +# libblas.a and liblapack.a archives that get linked into the binary. +if(_MYSTRAN_BLAS_LAPACK_MODE STREQUAL "EMBEDDED") list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_BLAS) - list(APPEND _MYSTRAN_STATIC_NAMES libblas_local.a) + list(APPEND _MYSTRAN_STATIC_NAMES libblas.a) + list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_LAPACK) + list(APPEND _MYSTRAN_STATIC_NAMES liblapack.a) endif() # On Windows the -static linker flag pulls in Fortran and C runtimes too @@ -616,11 +628,7 @@ endforeach() list(JOIN _MYSTRAN_STATIC_NAMES ", " _STATIC_NAMES_STR) message(STATUS "Static libraries linked in: ${_STATIC_NAMES_STR}") -# force some libraries -# LAPACK is currently always embedded (Source/Modules/LAPACK/*.f); the -# follow-up effort tracked in dev_docs/lapack_unification_prompt.md will -# make this conditional on _MYSTRAN_BLAS_MODE. -list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_LAPACK) +# ARPACK is always embedded under Source/Modules/ARPACK. list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_ARPACK) # ----------------------------------------------------------------------- @@ -888,16 +896,17 @@ else() set(_SLU_VARIANT "SuperLU (single-threaded)") endif() -# BLAS source -if(_MYSTRAN_BLAS_MODE STREQUAL "SYSTEM") +# BLAS / LAPACK source +if(_MYSTRAN_BLAS_LAPACK_MODE STREQUAL "SYSTEM") set(_BLAS_INFO "System: ${BLAS_LIBRARIES}") -elseif(MISSING_FNS_TOTAL GREATER 0) - set(_BLAS_INFO "Embedded reference (${MISSING_FNS_TOTAL} routine(s) compiled in)") + set(_LAPACK_INFO "System: ${LAPACK_LIBRARIES}") else() - set(_BLAS_INFO "System BLAS (provided by the OS, no routines compiled in)") + set(_BLAS_INFO "Embedded Reference-LAPACK submodule (libblas.a)") + set(_LAPACK_INFO "Embedded Reference-LAPACK submodule (liblapack.a)") endif() string(REPLACE "'" "''" _BLAS_INFO "${_BLAS_INFO}") +string(REPLACE "'" "''" _LAPACK_INFO "${_LAPACK_INFO}") # METIS if(TPL_ENABLE_METISLIB) @@ -930,6 +939,7 @@ string(APPEND _GEN_BLD_CONTENT " WRITE(IUNIT,'(A)') ' '\n" " WRITE(IUNIT,'(A)') ' Sparse solver : ${_SLU_VARIANT}'\n" " WRITE(IUNIT,'(A)') ' BLAS : ${_BLAS_INFO}'\n" + " WRITE(IUNIT,'(A)') ' LAPACK : ${_LAPACK_INFO}'\n" " WRITE(IUNIT,'(A)') ' METIS partitioner : ${_METIS_INFO}'\n" "END SUBROUTINE PRINT_BUILD_CONSTANTS\n" ) diff --git a/Source/Interfaces/CALC_GEN_MASS_Interface.f90 b/Source/Interfaces/CALC_GEN_MASS_Interface.f90 index a3d6eeb9..f757f1db 100644 --- a/Source/Interfaces/CALC_GEN_MASS_Interface.f90 +++ b/Source/Interfaces/CALC_GEN_MASS_Interface.f90 @@ -42,7 +42,6 @@ SUBROUTINE CALC_GEN_MASS USE MODEL_STUF, ONLY : EIG_CRIT, MAXMIJ, MIJ_COL, MIJ_ROW, NUM_FAIL_CRIT USE SPARSE_MATRICES, ONLY : I_KLLDn, J_KLLDn, KLLDn, I_MLLn, J_MLLn, MLLn USE SPARSE_MATRICES, ONLY : SYM_MLLn - USE LAPACK_BLAS_AUX IMPLICIT NONE diff --git a/Source/Interfaces/COND_NUM_Interface.f90 b/Source/Interfaces/COND_NUM_Interface.f90 index 7da68a16..1055c59c 100644 --- a/Source/Interfaces/COND_NUM_Interface.f90 +++ b/Source/Interfaces/COND_NUM_Interface.f90 @@ -37,7 +37,6 @@ SUBROUTINE COND_NUM ( MATIN_NAME, N, KD, K_INORM, MATIN_FAC, RCOND ) USE CONSTANTS_1, ONLY : ZERO USE PARAMS, ONLY : ITMAX USE TIMDAT, ONLY : TSEC - USE LAPACK_LIN_EQN_DPB IMPLICIT NONE diff --git a/Source/Interfaces/DSBAND_PREFAC_Interface.f90 b/Source/Interfaces/DSBAND_PREFAC_Interface.f90 index aff47eac..0ad78472 100644 --- a/Source/Interfaces/DSBAND_PREFAC_Interface.f90 +++ b/Source/Interfaces/DSBAND_PREFAC_Interface.f90 @@ -48,8 +48,6 @@ SUBROUTINE DSBAND_PREFAC ( RVEC, HOWMNY, SELECT, D, Z, LDZ, & & I_KMSMn, J_KMSMn, KMSMn USE ARPACK_LANCZOS_EIG, ONLY : dsaupd, dseupd, cr13_a - USE LAPACK_LIN_EQN_DGB - USE LAPACK_LIN_EQN_DPB IMPLICIT NONE diff --git a/Source/Interfaces/EIG_GIV_MGIV_Interface.f90 b/Source/Interfaces/EIG_GIV_MGIV_Interface.f90 index 0b06d7b4..df6e01d3 100644 --- a/Source/Interfaces/EIG_GIV_MGIV_Interface.f90 +++ b/Source/Interfaces/EIG_GIV_MGIV_Interface.f90 @@ -43,7 +43,7 @@ SUBROUTINE EIG_GIV_MGIV USE LAPACK_DPB_MATRICES, ONLY : ABAND, BBAND USE SPARSE_MATRICES, ONLY : I_KLL, J_KLL, KLL, I_KLLD, J_KLLD, KLLD, I_MLL, J_MLL, MLL USE DEBUG_PARAMETERS, ONLY : DEBUG - USE LAPACK_GIV_MGIV_EIG + USE MYSTRAN_LAPACK_EXT IMPLICIT NONE @@ -59,4 +59,3 @@ END SUBROUTINE EIG_GIV_MGIV END INTERFACE END MODULE EIG_GIV_MGIV_Interface - diff --git a/Source/Interfaces/EIG_INV_PWR_Interface.f90 b/Source/Interfaces/EIG_INV_PWR_Interface.f90 index ddbda6cc..39dcd807 100644 --- a/Source/Interfaces/EIG_INV_PWR_Interface.f90 +++ b/Source/Interfaces/EIG_INV_PWR_Interface.f90 @@ -43,7 +43,6 @@ SUBROUTINE EIG_INV_PWR USE SPARSE_MATRICES, ONLY : I_KLL, J_KLL, KLL, I_KLLD, J_KLLD, KLLD, I_MLL, J_MLL, MLL, & I_KMSM, I2_KMSM, J_KMSM, KMSM, I_KMSMs, I2_KMSMs, J_KMSMs, KMSMs USE SPARSE_MATRICES, ONLY : SYM_KLL, SYM_KLLD, SYM_MLL - USE LAPACK_LIN_EQN_DPB USE DEBUG_PARAMETERS, ONLY : DEBUG IMPLICIT NONE diff --git a/Source/Interfaces/EIG_LANCZOS_ARPACK_Interface.f90 b/Source/Interfaces/EIG_LANCZOS_ARPACK_Interface.f90 index b34580ad..be771c2f 100644 --- a/Source/Interfaces/EIG_LANCZOS_ARPACK_Interface.f90 +++ b/Source/Interfaces/EIG_LANCZOS_ARPACK_Interface.f90 @@ -50,6 +50,7 @@ SUBROUTINE EIG_LANCZOS_ARPACK I_KMSM, J_KMSM, KMSM, I_KMSMn, J_KMSMn, KMSMn, I_KMSMs, J_KMSMs, KMSMs USE ARPACK_LANCZOS_EIG + USE MYSTRAN_LAPACK_EXT IMPLICIT NONE @@ -63,4 +64,3 @@ END SUBROUTINE EIG_LANCZOS_ARPACK END INTERFACE END MODULE EIG_LANCZOS_ARPACK_Interface - diff --git a/Source/Interfaces/EPSCALC_Interface.f90 b/Source/Interfaces/EPSCALC_Interface.f90 index a1ab84f6..dae63ce8 100644 --- a/Source/Interfaces/EPSCALC_Interface.f90 +++ b/Source/Interfaces/EPSCALC_Interface.f90 @@ -42,7 +42,6 @@ SUBROUTINE EPSCALC ( ISUB ) USE SPARSE_MATRICES, ONLY : I_KLL, J_KLL, KLL USE SPARSE_MATRICES, ONLY : SYM_KLL USE COL_VECS, ONLY : UL_COL, PL_COL - USE LAPACK_BLAS_AUX IMPLICIT NONE diff --git a/Source/Interfaces/FBS_LAPACK_Interface.f90 b/Source/Interfaces/FBS_LAPACK_Interface.f90 index 473e613b..c40dbe19 100644 --- a/Source/Interfaces/FBS_LAPACK_Interface.f90 +++ b/Source/Interfaces/FBS_LAPACK_Interface.f90 @@ -40,7 +40,6 @@ SUBROUTINE FBS_LAPACK ( EQUED, NROWS, MATIN_SDIA, EQUIL_SCALE_FACS, INOUT_COL ) USE LAPACK_DPB_MATRICES, ONLY : ABAND, LAPACK_S, RES USE DEBUG_PARAMETERS, ONLY : DEBUG, NDEBUG USE MACHINE_PARAMS, ONLY : MACH_EPS, MACH_SFMIN - USE LAPACK_LIN_EQN_DPB IMPLICIT NONE diff --git a/Source/Interfaces/GET_MACHINE_PARAMS_Interface.f90 b/Source/Interfaces/GET_MACHINE_PARAMS_Interface.f90 index cc4fbcf5..6c5abc1e 100644 --- a/Source/Interfaces/GET_MACHINE_PARAMS_Interface.f90 +++ b/Source/Interfaces/GET_MACHINE_PARAMS_Interface.f90 @@ -39,7 +39,6 @@ SUBROUTINE GET_MACHINE_PARAMS USE MACHINE_PARAMS, ONLY : MACH_BASE, MACH_EMAX, MACH_EMIN, MACH_EPS, MACH_PREC, MACH_RMAX, MACH_RMIN, MACH_RND, & MACH_SFMIN, MACH_T, MACH_LARGE_NUM USE DEBUG_PARAMETERS, ONLY : DEBUG - USE LAPACK_BLAS_AUX IMPLICIT NONE diff --git a/Source/Interfaces/GPWG_PMOI_Interface.f90 b/Source/Interfaces/GPWG_PMOI_Interface.f90 index e6f2e2b2..d151a958 100644 --- a/Source/Interfaces/GPWG_PMOI_Interface.f90 +++ b/Source/Interfaces/GPWG_PMOI_Interface.f90 @@ -37,7 +37,6 @@ SUBROUTINE GPWG_PMOI (MOI1, Q, INFO ) USE TIMDAT, ONLY : TSEC USE CONSTANTS_1, ONLY : ZERO, ONE USE PARAMS, ONLY : SUPWARN, WTMASS - USE LAPACK_STD_EIG_1 IMPLICIT NONE diff --git a/Source/Interfaces/INVERT_EIGENS_Interface.f90 b/Source/Interfaces/INVERT_EIGENS_Interface.f90 index 6fc02fbc..94200729 100644 --- a/Source/Interfaces/INVERT_EIGENS_Interface.f90 +++ b/Source/Interfaces/INVERT_EIGENS_Interface.f90 @@ -38,7 +38,6 @@ SUBROUTINE INVERT_EIGENS ( MLAM, N, W, Z, EIG_NUM ) USE CONSTANTS_1, ONLY : ONE USE MACHINE_PARAMS, ONLY : MACH_SFMIN, MACH_LARGE_NUM USE MODEL_STUF, ONLY : EIG_SIGMA - USE LAPACK_BLAS_AUX IMPLICIT NONE diff --git a/Source/Interfaces/INVERT_FF_MAT_Interface.f90 b/Source/Interfaces/INVERT_FF_MAT_Interface.f90 index ce0ad750..326a0977 100644 --- a/Source/Interfaces/INVERT_FF_MAT_Interface.f90 +++ b/Source/Interfaces/INVERT_FF_MAT_Interface.f90 @@ -35,7 +35,6 @@ SUBROUTINE INVERT_FF_MAT ( CALLING_SUBR, MAT_A_NAME, A, NROWS, INFO ) USE IOUNT1, ONLY : WRT_ERR, ERR, F06 USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR USE TIMDAT, ONLY : TSEC - USE LAPACK_SYM_MAT_INV IMPLICIT NONE diff --git a/Source/Interfaces/LINK3_Interface.f90 b/Source/Interfaces/LINK3_Interface.f90 index 8e89dd4c..37cd174c 100644 --- a/Source/Interfaces/LINK3_Interface.f90 +++ b/Source/Interfaces/LINK3_Interface.f90 @@ -43,8 +43,6 @@ SUBROUTINE LINK3 USE COL_VECS, ONLY : UL_COL, PL_COL USE MACHINE_PARAMS, ONLY : MACH_EPS, MACH_SFMIN USE DEBUG_PARAMETERS, ONLY : DEBUG - USE LAPACK_BLAS_AUX - USE LAPACK_LIN_EQN_DPB USE SCRATCH_MATRICES, ONLY : I_CCS1, J_CCS1, CCS1 USE SuperLU_STUF, ONLY : SLU_FACTORS, SLU_INFO diff --git a/Source/Interfaces/SOLVE_DLR_Interface.f90 b/Source/Interfaces/SOLVE_DLR_Interface.f90 index d9afe50e..26654d71 100644 --- a/Source/Interfaces/SOLVE_DLR_Interface.f90 +++ b/Source/Interfaces/SOLVE_DLR_Interface.f90 @@ -41,7 +41,6 @@ SUBROUTINE SOLVE_DLR USE SPARSE_MATRICES, ONLY : I2_DLR, I_DLR, J_DLR, DLR, I_DLRt, I2_DLRt, J_DLRt, DLRt, I_KRL, J_KRL, KRL, & I_KLL, I2_KLL, J_KLL, KLL - USE LAPACK_LIN_EQN_DPB IMPLICIT NONE diff --git a/Source/Interfaces/SOLVE_GOA_Interface.f90 b/Source/Interfaces/SOLVE_GOA_Interface.f90 index b28e5ee3..3c30aa78 100644 --- a/Source/Interfaces/SOLVE_GOA_Interface.f90 +++ b/Source/Interfaces/SOLVE_GOA_Interface.f90 @@ -40,7 +40,6 @@ SUBROUTINE SOLVE_GOA USE CONSTANTS_1, ONLY : ZERO, ONE USE PARAMS, ONLY : SOLLIB, SPARSE_FLAVOR USE SPARSE_MATRICES, ONLY : I2_GOA, I_GOA, J_GOA, GOA, I_KOO, J_KOO, KOO, I_KAO, J_KAO, KAO - USE LAPACK_LIN_EQN_DPB IMPLICIT NONE diff --git a/Source/Interfaces/SOLVE_PHIZL1_Interface.f90 b/Source/Interfaces/SOLVE_PHIZL1_Interface.f90 index 168b66c5..abf3b743 100644 --- a/Source/Interfaces/SOLVE_PHIZL1_Interface.f90 +++ b/Source/Interfaces/SOLVE_PHIZL1_Interface.f90 @@ -41,7 +41,6 @@ SUBROUTINE SOLVE_PHIZL1 ( NTERM_CRS3 ) USE SCRATCH_MATRICES, ONLY : I_CRS3, J_CRS3, CRS3 USE SPARSE_MATRICES, ONLY : I2_PHIZL1, I_PHIZL1, J_PHIZL1, PHIZL1, I2_PHIZL1t, I_PHIZL1t, J_PHIZL1t, PHIZL1t, & I_KLL, I2_KLL, J_KLL, KLL, I_KLLs, I2_KLLs, J_KLLs, KLLs - USE LAPACK_LIN_EQN_DPB IMPLICIT NONE diff --git a/Source/Interfaces/SOLVE_UO0_Interface.f90 b/Source/Interfaces/SOLVE_UO0_Interface.f90 index 942b58a1..479ae03b 100644 --- a/Source/Interfaces/SOLVE_UO0_Interface.f90 +++ b/Source/Interfaces/SOLVE_UO0_Interface.f90 @@ -39,7 +39,6 @@ SUBROUTINE SOLVE_UO0 USE PARAMS, ONLY : PRTUO0, SOLLIB, SPARSE_FLAVOR USE SPARSE_MATRICES, ONLY : I_PO, J_PO, PO, I_KOO, J_KOO, KOO USE COL_VECS, ONLY : UO0_COL - USE LAPACK_LIN_EQN_DPB IMPLICIT NONE diff --git a/Source/Interfaces/STIFF_MAT_EQUIL_CHK_Interface.f90 b/Source/Interfaces/STIFF_MAT_EQUIL_CHK_Interface.f90 index 0db0b99a..23246511 100644 --- a/Source/Interfaces/STIFF_MAT_EQUIL_CHK_Interface.f90 +++ b/Source/Interfaces/STIFF_MAT_EQUIL_CHK_Interface.f90 @@ -40,7 +40,6 @@ SUBROUTINE STIFF_MAT_EQUIL_CHK ( OUTPUT, X_SET, SYM_KIN, NROWS, NTERM_KIN, I_KIN USE DOF_TABLES, ONLY : TDOFI USE DEBUG_PARAMETERS, ONLY : DEBUG USE LAPACK_DPB_MATRICES, ONLY : ABAND - USE LAPACK_BLAS_AUX USE PARAMS, ONLY : EPSIL, EQCHK_NORM, SUPWARN, SUPINFO USE DEBUG_PARAMETERS, ONLY : DEBUG diff --git a/Source/Interfaces/SYM_MAT_DECOMP_LAPACK_Interface.f90 b/Source/Interfaces/SYM_MAT_DECOMP_LAPACK_Interface.f90 index e01413e8..263ce67d 100644 --- a/Source/Interfaces/SYM_MAT_DECOMP_LAPACK_Interface.f90 +++ b/Source/Interfaces/SYM_MAT_DECOMP_LAPACK_Interface.f90 @@ -42,7 +42,6 @@ SUBROUTINE SYM_MAT_DECOMP_LAPACK ( CALLING_SUBR, MATIN_NAME, MATIN_SET, NROWS, N USE LAPACK_DPB_MATRICES, ONLY : ABAND, LAPACK_S USE DEBUG_PARAMETERS, ONLY : DEBUG, NDEBUG USE MACHINE_PARAMS, ONLY : MACH_LARGE_NUM - USE LAPACK_LIN_EQN_DPB IMPLICIT NONE diff --git a/Source/LK1/L1C/GPWG_PMOI.f90 b/Source/LK1/L1C/GPWG_PMOI.f90 index 739e9bd4..f5741ed4 100644 --- a/Source/LK1/L1C/GPWG_PMOI.f90 +++ b/Source/LK1/L1C/GPWG_PMOI.f90 @@ -34,7 +34,6 @@ SUBROUTINE GPWG_PMOI (MOI1, Q, INFO ) USE TIMDAT, ONLY : TSEC USE CONSTANTS_1, ONLY : ZERO, ONE USE PARAMS, ONLY : SUPWARN, WTMASS - USE LAPACK_STD_EIG_1 USE GPWG_PMOI_USE_IFs diff --git a/Source/LK1/L1E/KGG_SINGULARITY_PROC.f90 b/Source/LK1/L1E/KGG_SINGULARITY_PROC.f90 index f4df7cbf..eb4f198e 100644 --- a/Source/LK1/L1E/KGG_SINGULARITY_PROC.f90 +++ b/Source/LK1/L1E/KGG_SINGULARITY_PROC.f90 @@ -288,7 +288,6 @@ SUBROUTINE K33_EIGENS (K33, K33_LAMBDAS, K33_VECS, INFO ) USE IOUNT1, ONLY : WRT_ERR, ERR, F06 USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR USE CONSTANTS_1, ONLY : ZERO - USE LAPACK_STD_EIG_1 IMPLICIT NONE @@ -375,7 +374,6 @@ SUBROUTINE KGG_SING_PROC_DEBUG ( WHAT ) USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE USE IOUNT1, ONLY : WRT_ERR, F06 USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE LAPACK_STD_EIG_1 IMPLICIT NONE diff --git a/Source/LK2/SOLVE_GMN.f90 b/Source/LK2/SOLVE_GMN.f90 index 89bcf182..c037cd95 100644 --- a/Source/LK2/SOLVE_GMN.f90 +++ b/Source/LK2/SOLVE_GMN.f90 @@ -275,7 +275,6 @@ SUBROUTINE SOLVE_GMN_SOLVER USE SPARSE_MATRICES, ONLY : I_RMN, J_RMN, RMN, I_RMM, J_RMM, RMM, I2_GMN, I_GMN, J_GMN, GMN USE SCRATCH_MATRICES, ONLY : I_CCS1, J_CCS1, CCS1 USE FULL_MATRICES, ONLY : RMM_FULL - USE LAPACK_LIN_EQN_DGE USE SuperLU_STUF, ONLY : SLU_FACTORS, SLU_INFO ! Interface module not needed for subr's DGETRF and DGETRS. These are "CONTAIN'ed" in module LAPACK_LIN_EQN_DPB, which diff --git a/Source/LK2/SOLVE_GOA.f90 b/Source/LK2/SOLVE_GOA.f90 index aac1665d..dd287ebf 100644 --- a/Source/LK2/SOLVE_GOA.f90 +++ b/Source/LK2/SOLVE_GOA.f90 @@ -31,7 +31,7 @@ SUBROUTINE SOLVE_GOA ! load matrices from the F-set to the A, O_sets USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : FILE_NAM_MAXLEN, ERR, F06, SCR + USE IOUNT1, ONLY : FILE_NAM_MAXLEN, ERR, F06, SCR, SC1 USE SCONTR, ONLY : BLNK_SUB_NAM, FACTORED_MATRIX, FATAL_ERR, KOO_SDIA, NDOFA, NDOFO, NTERM_GOA, NTERM_KOO, & NTERM_KAO USE PARAMS, ONLY : EPSIL, PRTGOA @@ -39,7 +39,6 @@ SUBROUTINE SOLVE_GOA USE CONSTANTS_1, ONLY : ZERO, ONE USE PARAMS, ONLY : SOLLIB, SPARSE_FLAVOR USE SPARSE_MATRICES, ONLY : I2_GOA, I_GOA, J_GOA, GOA, I_KOO, J_KOO, KOO, I_KAO, J_KAO, KAO - USE LAPACK_LIN_EQN_DPB ! Interface module not needed for subr's DPBTRF and DPBTRS. These are "CONTAIN'ed" in module LAPACK_LIN_EQN_DPB, which ! is "USE'd" above diff --git a/Source/LK2/SOLVE_UO0.f90 b/Source/LK2/SOLVE_UO0.f90 index 2165bba2..1ff27d8a 100644 --- a/Source/LK2/SOLVE_UO0.f90 +++ b/Source/LK2/SOLVE_UO0.f90 @@ -29,14 +29,13 @@ SUBROUTINE SOLVE_UO0 ! Solves KOO*UO0 = PO for matrix UO0 USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, L2F, LINK2F, L2F_MSG + USE IOUNT1, ONLY : ERR, F06, L2F, LINK2F, L2F_MSG, SC1 USE SCONTR, ONLY : BLNK_SUB_NAM, FACTORED_MATRIX, FATAL_ERR, KOO_SDIA, NDOFO, NSUB, NTERM_KOO, NTERM_PO USE TIMDAT, ONLY : TSEC USE CONSTANTS_1, ONLY : ZERO, ONE USE PARAMS, ONLY : PRTUO0, SOLLIB, SPARSE_FLAVOR USE SPARSE_MATRICES, ONLY : I_PO, J_PO, PO, I_KOO, J_KOO, KOO USE COL_VECS, ONLY : UO0_COL - USE LAPACK_LIN_EQN_DPB ! Interface module not needed for subr DPBTRS. This is "CONTAIN'ed" in module LAPACK_LIN_EQN_DPB, which is "USE'd" above diff --git a/Source/LK2/STIFF_MAT_EQUIL_CHK.f90 b/Source/LK2/STIFF_MAT_EQUIL_CHK.f90 index a58f812d..e0911c3e 100644 --- a/Source/LK2/STIFF_MAT_EQUIL_CHK.f90 +++ b/Source/LK2/STIFF_MAT_EQUIL_CHK.f90 @@ -32,7 +32,7 @@ SUBROUTINE STIFF_MAT_EQUIL_CHK ( OUTPUT, X_SET, SYM_KIN, NROWS, NTERM_KIN, I_KIN ! example would be the case if it were grounded - e.g. a cantilevered beam has rigid body modes restrained) USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : WRT_ERR, ERR, F06 + USE IOUNT1, ONLY : WRT_ERR, ERR, F06, SC1 USE SCONTR, ONLY : BLNK_SUB_NAM, NSPOINT, WARN_ERR USE TIMDAT, ONLY : TSEC @@ -40,7 +40,6 @@ SUBROUTINE STIFF_MAT_EQUIL_CHK ( OUTPUT, X_SET, SYM_KIN, NROWS, NTERM_KIN, I_KIN USE DOF_TABLES, ONLY : TDOFI USE DEBUG_PARAMETERS, ONLY : DEBUG USE LAPACK_DPB_MATRICES, ONLY : ABAND - USE LAPACK_BLAS_AUX USE PARAMS, ONLY : EPSIL, EQCHK_NORM, SUPWARN, SUPINFO USE DEBUG_PARAMETERS, ONLY : DEBUG @@ -179,7 +178,7 @@ SUBROUTINE STIFF_MAT_EQUIL_CHK ( OUTPUT, X_SET, SYM_KIN, NROWS, NTERM_KIN, I_KIN RBMAT_COL(I) = RBMAT(I,J) PRB_COL(I) = ZERO ENDDO - CALL DSBMV ( 'U', NROWS, KIN_SDIA, 1.0D0, ABAND, KIN_SDIA+1, RBMAT_COL, 1, 0.0D0, PRB_COL, 1, J ) + CALL DSBMV ( 'U', NROWS, KIN_SDIA, 1.0D0, ABAND, KIN_SDIA+1, RBMAT_COL, 1, 0.0D0, PRB_COL, 1 ) DO I=1,NROWS PRB(I,J) = PRB_COL(I) ENDDO diff --git a/Source/LK3/EPSCALC.f90 b/Source/LK3/EPSCALC.f90 index c0b4f5cc..a2bf5a83 100644 --- a/Source/LK3/EPSCALC.f90 +++ b/Source/LK3/EPSCALC.f90 @@ -41,7 +41,6 @@ SUBROUTINE EPSCALC ( ISUB ) USE SPARSE_MATRICES, ONLY : I_KLL, J_KLL, KLL USE SPARSE_MATRICES, ONLY : SYM_KLL USE COL_VECS, ONLY : UL_COL, PL_COL - USE LAPACK_BLAS_AUX USE EPSCALC_USE_IFs @@ -59,6 +58,8 @@ SUBROUTINE EPSCALC ( ISUB ) REAL(DOUBLE) :: KU(NDOFL) ! Result of multiplying KLL and UL_COL REAL(DOUBLE) :: NUM ! Numerator in EPSILON calculation + REAL(DOUBLE), EXTERNAL :: DDOT ! BLAS dot-product function + INTRINSIC :: DABS diff --git a/Source/LK3/LINK3.f90 b/Source/LK3/LINK3.f90 index 85904386..8e32f795 100644 --- a/Source/LK3/LINK3.f90 +++ b/Source/LK3/LINK3.f90 @@ -45,8 +45,6 @@ SUBROUTINE LINK3 USE COL_VECS, ONLY : UL_COL, PL_COL USE MACHINE_PARAMS, ONLY : MACH_EPS, MACH_SFMIN USE DEBUG_PARAMETERS, ONLY : DEBUG - USE LAPACK_BLAS_AUX - USE LAPACK_LIN_EQN_DPB USE SCRATCH_MATRICES, ONLY : I_CCS1, J_CCS1, CCS1 USE SuperLU_STUF, ONLY : SLU_FACTORS, SLU_INFO diff --git a/Source/LK4/CALC_GEN_MASS.f90 b/Source/LK4/CALC_GEN_MASS.f90 index b02d099d..1b217093 100644 --- a/Source/LK4/CALC_GEN_MASS.f90 +++ b/Source/LK4/CALC_GEN_MASS.f90 @@ -50,7 +50,6 @@ SUBROUTINE CALC_GEN_MASS USE MODEL_STUF, ONLY : EIG_CRIT, MAXMIJ, MIJ_COL, MIJ_ROW, NUM_FAIL_CRIT USE SPARSE_MATRICES, ONLY : I_KLLDn, J_KLLDn, KLLDn, I_MLLn, J_MLLn, MLLn USE SPARSE_MATRICES, ONLY : SYM_MLLn - USE LAPACK_BLAS_AUX USE CALC_GEN_MASS_USE_IFs @@ -69,6 +68,8 @@ SUBROUTINE CALC_GEN_MASS REAL(DOUBLE) :: OUTVECJ(NDOFL,1) ! One eigenvector REAL(DOUBLE) :: ZVEC(NDOFL,1) ! Intermediate matrix in the calculation of GEN_MASS + REAL(DOUBLE), EXTERNAL :: DDOT ! BLAS dot-product function + INTRINSIC :: DABS diff --git a/Source/LK4/DSBAND_PREFAC.f b/Source/LK4/DSBAND_PREFAC.f index 14153c2c..407b8c97 100644 --- a/Source/LK4/DSBAND_PREFAC.f +++ b/Source/LK4/DSBAND_PREFAC.f @@ -54,8 +54,6 @@ subroutine dsband_prefac( rvec, howmny, select, d, z, ldz, sigma, & I_KMSMn, J_KMSMn, KMSMn USE ARPACK_LANCZOS_EIG, ONLY : dsaupd, dseupd, cr13_a - USE LAPACK_LIN_EQN_DGB - USE LAPACK_LIN_EQN_DPB USE OURTIM_Interface USE MATMULT_SFF_Interface @@ -295,13 +293,12 @@ subroutine dsband_prefac( rvec, howmny, select, d, z, ldz, sigma, if (eig_lap_mat_type(1:3) == 'DGB') then call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, - & iwork, workd(ipntr(2)), n, ierr, - & dtbsv_msg) + & iwork, workd(ipntr(2)), n, ierr ) else if (eig_lap_mat_type(1:3) == 'DPB') then call dpbtrs ( 'U', n, ku, 1, rfac, ku+1, - & workd(ipntr(2)), n, ierr, 'N' ) + & workd(ipntr(2)), n, ierr ) endif IF (EIG_MSGLVL > 0) CALL ARP_DEB_PREFAC(2,N,IDO,IPNTR, @@ -358,13 +355,12 @@ subroutine dsband_prefac( rvec, howmny, select, d, z, ldz, sigma, if (eig_lap_mat_type(1:3) == 'DGB') then call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, - & iwork, workd(ipntr(2)), n, ierr, - & dtbsv_msg) + & iwork, workd(ipntr(2)), n, ierr ) else if (eig_lap_mat_type(1:3) == 'DPB') then call dpbtrs ( 'U', n, ku, 1, rfac, ku+1, - & workd(ipntr(2)), n, ierr, 'N' ) + & workd(ipntr(2)), n, ierr ) endif IF (EIG_MSGLVL > 0) CALL ARP_DEB_PREFAC(2,N,IDO,IPNTR, & KLLDn_DIAG,MLLn_DIAG,KMSMn_DIAG,WORKD1,WORKD2,RFAC,IMID) @@ -424,13 +420,12 @@ subroutine dsband_prefac( rvec, howmny, select, d, z, ldz, sigma, if (eig_lap_mat_type(1:3) == 'DGB') then call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, - & iwork, workd(ipntr(2)), n, ierr, - & dtbsv_msg) + & iwork, workd(ipntr(2)), n, ierr ) else if (eig_lap_mat_type(1:3) == 'DPB') then call dpbtrs ( 'U', n, ku, 1, rfac, ku+1, - & workd(ipntr(2)), n, ierr, 'N' ) + & workd(ipntr(2)), n, ierr ) endif IF (EIG_MSGLVL > 0) CALL ARP_DEB_PREFAC(2,N,IDO,IPNTR, @@ -467,13 +462,12 @@ subroutine dsband_prefac( rvec, howmny, select, d, z, ldz, sigma, if (eig_lap_mat_type(1:3) == 'DGB') then call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, - & iwork, workd(ipntr(2)), n, ierr, - & dtbsv_msg) + & iwork, workd(ipntr(2)), n, ierr ) else if (eig_lap_mat_type(1:3) == 'DPB') then call dpbtrs ( 'U', n, ku, 1, rfac, ku+1, - & workd(ipntr(2)), n, ierr, 'N' ) + & workd(ipntr(2)), n, ierr ) endif IF (EIG_MSGLVL > 0) CALL ARP_DEB_PREFAC(2,N,IDO,IPNTR, diff --git a/Source/LK4/EIG_GIV_MGIV.f90 b/Source/LK4/EIG_GIV_MGIV.f90 index 28508def..b0978261 100644 --- a/Source/LK4/EIG_GIV_MGIV.f90 +++ b/Source/LK4/EIG_GIV_MGIV.f90 @@ -29,7 +29,7 @@ SUBROUTINE EIG_GIV_MGIV ! Solves for eigenvalues and eigenvectors when method is GIV (Givens) or MGIV (modified Givens) USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : WRT_ERR, ERR, F06 + USE IOUNT1, ONLY : WRT_ERR, ERR, F06, SC1 USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR, KLL_SDIA, KLLD_SDIA, MLL_SDIA, NDOFL, NTERM_KLL, NTERM_KLLD, & NTERM_MLL, NUM_EIGENS, NUM_KLLD_DIAG_ZEROS, NUM_MLL_DIAG_ZEROS, NVEC, SOL_NAME, WARN_ERR USE TIMDAT, ONLY : TSEC @@ -40,8 +40,8 @@ SUBROUTINE EIG_GIV_MGIV USE LAPACK_DPB_MATRICES, ONLY : ABAND, BBAND USE SPARSE_MATRICES, ONLY : I_KLL, J_KLL, KLL, I_KLLD, J_KLLD, KLLD, I_MLL, J_MLL, MLL USE DEBUG_PARAMETERS, ONLY : DEBUG - USE LAPACK_GIV_MGIV_EIG + USE MYSTRAN_LAPACK_EXT USE EIG_GIV_MGIV_USE_IFs USE LINK_MESSAGE_Interface diff --git a/Source/LK4/EIG_INV_PWR.f90 b/Source/LK4/EIG_INV_PWR.f90 index dc074a78..e685faf7 100644 --- a/Source/LK4/EIG_INV_PWR.f90 +++ b/Source/LK4/EIG_INV_PWR.f90 @@ -30,7 +30,7 @@ SUBROUTINE EIG_INV_PWR ! iterative method USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : WRT_ERR, ERR, F06 + USE IOUNT1, ONLY : WRT_ERR, ERR, F06, SC1 USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR, KMSM_SDIA, LINKNO, NDOFL, NTERM_KLL, NTERM_KLLD, NTERM_KMSM, & NTERM_KMSMs, NTERM_MLL, NUM_EIGENS, NVEC, SOL_NAME, WARN_ERR USE TIMDAT, ONLY : TSEC @@ -41,7 +41,6 @@ SUBROUTINE EIG_INV_PWR USE SPARSE_MATRICES, ONLY : I_KLL, J_KLL, KLL, I_KLLD, J_KLLD, KLLD, I_MLL, J_MLL, MLL, & I_KMSM, I2_KMSM, J_KMSM, KMSM, I_KMSMs, I2_KMSMs, J_KMSMs, KMSMs USE SPARSE_MATRICES, ONLY : SYM_KLL, SYM_KLLD, SYM_MLL - USE LAPACK_LIN_EQN_DPB USE DEBUG_PARAMETERS, ONLY : DEBUG USE EIG_INV_PWR_USE_IFs diff --git a/Source/LK4/EIG_LANCZOS_ARPACK.f90 b/Source/LK4/EIG_LANCZOS_ARPACK.f90 index 166cc68f..2517eeab 100644 --- a/Source/LK4/EIG_LANCZOS_ARPACK.f90 +++ b/Source/LK4/EIG_LANCZOS_ARPACK.f90 @@ -47,6 +47,7 @@ SUBROUTINE EIG_LANCZOS_ARPACK I_KMSM, J_KMSM, KMSM, I_KMSMn, J_KMSMn, KMSMn, I_KMSMs, J_KMSMs, KMSMs USE ARPACK_LANCZOS_EIG + USE MYSTRAN_LAPACK_EXT USE EIG_LANCZOS_ARPACK_USE_IFs USE LINK_MESSAGE_Interface @@ -556,9 +557,6 @@ SUBROUTINE EIG_LANCZOS_ARPACK SUBROUTINE EST_NUM_EIGENS_BANDED ( FREQ, NUM_NEG_TERMS ) - USE LAPACK_GIV_MGIV_EIG - USE LAPACK_LIN_EQN_DGE - USE LAPACK_BLAS_AUX IMPLICIT NONE diff --git a/Source/LK4/EIG_LANCZOS_ARPACK_ADAPTIVE.f90 b/Source/LK4/EIG_LANCZOS_ARPACK_ADAPTIVE.f90 index 4395a90d..3c5a48a0 100644 --- a/Source/LK4/EIG_LANCZOS_ARPACK_ADAPTIVE.f90 +++ b/Source/LK4/EIG_LANCZOS_ARPACK_ADAPTIVE.f90 @@ -56,8 +56,6 @@ SUBROUTINE EIG_LANCZOS_ARPACK_ADAPTIVE USE SuperLU_STUF, ONLY : SLU_FACTORS, SLU_INFO USE ARPACK_LANCZOS_EIG - USE LAPACK_LIN_EQN_DPB - USE LAPACK_LIN_EQN_DGB USE EIG_LANCZOS_ARPACK_ADAPTIVE_USE_IFs USE DSBAND_PREFAC_Interface diff --git a/Source/LK4/INVERT_EIGENS.f90 b/Source/LK4/INVERT_EIGENS.f90 index ca06e985..8ebfb6a5 100644 --- a/Source/LK4/INVERT_EIGENS.f90 +++ b/Source/LK4/INVERT_EIGENS.f90 @@ -36,7 +36,6 @@ SUBROUTINE INVERT_EIGENS ( MLAM, N, W, Z, EIG_NUM ) USE CONSTANTS_1, ONLY : ONE USE MACHINE_PARAMS, ONLY : MACH_SFMIN, MACH_LARGE_NUM USE MODEL_STUF, ONLY : EIG_SIGMA - USE LAPACK_BLAS_AUX USE INVERT_EIGENS_USE_IFs diff --git a/Source/LK6/SOLVE_DLR.f90 b/Source/LK6/SOLVE_DLR.f90 index d4945828..24a49e2c 100644 --- a/Source/LK6/SOLVE_DLR.f90 +++ b/Source/LK6/SOLVE_DLR.f90 @@ -41,7 +41,6 @@ SUBROUTINE SOLVE_DLR USE SPARSE_MATRICES, ONLY : I2_DLR, I_DLR, J_DLR, DLR, I_DLRt, I2_DLRt, J_DLRt, DLRt, I_KRL, J_KRL, KRL, & I_KLL, I2_KLL, J_KLL, KLL - USE LAPACK_LIN_EQN_DPB USE SOLVE_DLR_USE_IFs diff --git a/Source/LK6/SOLVE_PHIZL1.f90 b/Source/LK6/SOLVE_PHIZL1.f90 index a11f4a83..97968241 100644 --- a/Source/LK6/SOLVE_PHIZL1.f90 +++ b/Source/LK6/SOLVE_PHIZL1.f90 @@ -42,7 +42,6 @@ SUBROUTINE SOLVE_PHIZL1 ( NTERM_CRS3 ) USE SCRATCH_MATRICES, ONLY : I_CRS3, J_CRS3, CRS3 USE SPARSE_MATRICES, ONLY : I2_PHIZL1, I_PHIZL1, J_PHIZL1, PHIZL1, I2_PHIZL1t, I_PHIZL1t, J_PHIZL1t, PHIZL1t, & I_KLL, I2_KLL, J_KLL, KLL, I_KLLs, I2_KLLs, J_KLLs, KLLs - USE LAPACK_LIN_EQN_DPB USE SOLVE_PHIZL1_USE_IFs diff --git a/Source/LK9/L91/PRINCIPAL_3D.f90 b/Source/LK9/L91/PRINCIPAL_3D.f90 index c4736d67..91d99385 100644 --- a/Source/LK9/L91/PRINCIPAL_3D.f90 +++ b/Source/LK9/L91/PRINCIPAL_3D.f90 @@ -121,7 +121,6 @@ SUBROUTINE ROOTS_3D ( STR_TENSOR, Q, INFO ) USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR, WARN_ERR USE TIMDAT, ONLY : TSEC USE CONSTANTS_1, ONLY : ZERO, ONE - USE LAPACK_STD_EIG_1 IMPLICIT NONE diff --git a/Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f b/Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f index ae164e98..6a88ed3e 100644 --- a/Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f +++ b/Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f @@ -10,11 +10,6 @@ MODULE ARPACK_LANCZOS_EIG USE SuperLU_STUF, ONLY : SLU_FACTORS, SLU_INFO USE PARAMS, ONLY : SOLLIB USE ARPACK_UTIL - USE LAPACK_BLAS_AUX - USE LAPACK_LANCZOS_EIG - USE LAPACK_MISCEL ! This contains DSTEQR, used in this module - USE LAPACK_LIN_EQN_DGB - USE LAPACK_LIN_EQN_DPB USE OURTIM_Interface USE MATMULT_SFF_Interface @@ -858,13 +853,12 @@ subroutine dsband( rvec, howmny, select, d, z, ldz, sigma, if (eig_lap_mat_type(1:3) == 'DGB') then call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, - & iwork, workd(ipntr(2)), n, ierr, - & dtbsv_msg) + & iwork, workd(ipntr(2)), n, ierr ) else if (eig_lap_mat_type(1:3) == 'DPB') then call dpbtrs ( 'U', n, ku, 1, rfac, ku+1, - & workd(ipntr(2)), n, ierr, 'N' ) + & workd(ipntr(2)), n, ierr ) endif IF (EIG_MSGLVL > 0) CALL ARP_DEB(2,N,IDO,IPNTR) @@ -919,13 +913,12 @@ subroutine dsband( rvec, howmny, select, d, z, ldz, sigma, if (eig_lap_mat_type(1:3) == 'DGB') then call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, - & iwork, workd(ipntr(2)), n, ierr, - & dtbsv_msg) + & iwork, workd(ipntr(2)), n, ierr ) else if (eig_lap_mat_type(1:3) == 'DPB') then call dpbtrs ( 'U', n, ku, 1, rfac, ku+1, - & workd(ipntr(2)), n, ierr, 'N' ) + & workd(ipntr(2)), n, ierr ) endif IF (EIG_MSGLVL > 0) CALL ARP_DEB(2,N,IDO,IPNTR) @@ -983,13 +976,12 @@ subroutine dsband( rvec, howmny, select, d, z, ldz, sigma, if (eig_lap_mat_type(1:3) == 'DGB') then call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, - & iwork, workd(ipntr(2)), n, ierr, - & dtbsv_msg) + & iwork, workd(ipntr(2)), n, ierr ) else if (eig_lap_mat_type(1:3) == 'DPB') then call dpbtrs ( 'U', n, ku, 1, rfac, ku+1, - & workd(ipntr(2)), n, ierr, 'N' ) + & workd(ipntr(2)), n, ierr ) endif IF (EIG_MSGLVL > 0) CALL ARP_DEB(2,N,IDO,IPNTR) @@ -1025,13 +1017,12 @@ subroutine dsband( rvec, howmny, select, d, z, ldz, sigma, if (eig_lap_mat_type(1:3) == 'DGB') then call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, - & iwork, workd(ipntr(2)), n, ierr, - & dtbsv_msg) + & iwork, workd(ipntr(2)), n, ierr ) else if (eig_lap_mat_type(1:3) == 'DPB') then call dpbtrs ( 'U', n, ku, 1, rfac, ku+1, - & workd(ipntr(2)), n, ierr, 'N' ) + & workd(ipntr(2)), n, ierr ) endif IF (EIG_MSGLVL > 0) CALL ARP_DEB(2,N,IDO,IPNTR) diff --git a/Source/Modules/LAPACK/LAPACK_BLAS_AUX.f b/Source/Modules/LAPACK/LAPACK_BLAS_AUX.f deleted file mode 100644 index d343524c..00000000 --- a/Source/Modules/LAPACK/LAPACK_BLAS_AUX.f +++ /dev/null @@ -1,11764 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_BLAS_AUX - -! This is the set of LAPACK auxiliary routines called by other LAPACK subroutines - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - USE PARAMS, ONLY : NOCOUNTS - - USE OUTA_HERE_Interface - - character(1*byte), parameter :: cr13_lba = char(13) - - CONTAINS - -! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -! BLAS routines - -! ################################################################################################################################## -! 001 LAPACK_BLAS_AUX - - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -c -c takes the sum of the absolute values. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL(DOUBLE) dx(*),dtemp - integer i,incx,m,mp1,n,nincx -c - dasum = 0.0d0 - dtemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dtemp = dtemp + dabs(dx(i)) - 10 continue - dasum = dtemp - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,6) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dabs(dx(i)) - 30 continue - if( n .lt. 6 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,6 - dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) - * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) - 50 continue - 60 dasum = dtemp - return - - END FUNCTION DASUM - -! ################################################################################################################################## -! 002 LAPACK_BLAS_AUX - - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -c -c constant times a vector plus a vector. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL(DOUBLE) dx(*),dy(*),da - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if (da .eq. 0.0d0) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dy(iy) + da*dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,4) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dy(i) + da*dx(i) - 30 continue - if( n .lt. 4 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,4 - dy(i) = dy(i) + da*dx(i) - dy(i + 1) = dy(i + 1) + da*dx(i + 1) - dy(i + 2) = dy(i + 2) + da*dx(i + 2) - dy(i + 3) = dy(i + 3) + da*dx(i + 3) - 50 continue - return - - END SUBROUTINE DAXPY - -! ################################################################################################################################## -! 003 LAPACK_BLAS_AUX - - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL(DOUBLE) dx(*),dy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - 50 continue - return - - END SUBROUTINE DCOPY - -! ################################################################################################################################## -! 004 LAPACK_BLAS_AUX - - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) -c -c forms the dot product of two vectors. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL(DOUBLE) dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - ddot = 0.0d0 - dtemp = 0.0d0 - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dtemp + dx(ix)*dy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - ddot = dtemp - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dx(i)*dy(i) - 30 continue - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + - * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) - 50 continue - 60 ddot = dtemp - return - - END FUNCTION DDOT - -! ################################################################################################################################## -! 005 LAPACK_BLAS_AUX - - SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - REAL(DOUBLE) ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGBMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n band matrix, with kl sub-diagonals and ku super-diagonals. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* KL - INTEGER. -* On entry, KL specifies the number of sub-diagonals of the -* matrix A. KL must satisfy 0 .le. KL. -* Unchanged on exit. -* -* KU - INTEGER. -* On entry, KU specifies the number of super-diagonals of the -* matrix A. KU must satisfy 0 .le. KU. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry, the leading ( kl + ku + 1 ) by n part of the -* array A must contain the matrix of coefficients, supplied -* column by column, with the leading diagonal of the matrix in -* row ( ku + 1 ) of the array, the first super-diagonal -* starting at position 2 in row ku, the first sub-diagonal -* starting at position 1 in row ( ku + 2 ), and so on. -* Elements in the array A that do not correspond to elements -* in the band matrix (such as the top left ku by ku triangle) -* are not referenced. -* The following program segment will transfer a band matrix -* from conventional full matrix storage to band storage: -* -* DO 20, J = 1, N -* K = KU + 1 - J -* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -* A( K + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( kl + ku + 1 ). -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL(DOUBLE). -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - REAL(DOUBLE) array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( KL.LT.0 )THEN - INFO = 4 - ELSE IF( KU.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN - INFO = 8 - ELSE IF( INCX.EQ.0 )THEN - INFO = 10 - ELSE IF( INCY.EQ.0 )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the band part of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KUP1 = KU + 1 - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - K = KUP1 - J - DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - K = KUP1 - J - DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - K = KUP1 - J - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGBMV . -* - END SUBROUTINE DGBMV - -! ################################################################################################################################## -! 008 LAPACK_BLAS_AUX - - SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) - -* .. Scalar Arguments .. - REAL(DOUBLE) ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGER performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - REAL(DOUBLE) array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END SUBROUTINE DGER - -! ################################################################################################################################## -! 009 LAPACK_BLAS_AUX - - DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) - -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - REAL(DOUBLE) X( * ) -* .. -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - REAL(DOUBLE) ABSXI, NORM, SCALE, SSQ -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE IF( N.EQ.1 )THEN - NORM = ABS( X( 1 ) ) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SSQ = ONE + SSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END FUNCTION DNRM2 - -! ################################################################################################################################## -! 010 LAPACK_BLAS_AUX - - SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S) -c -c applies a plane rotation. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL(DOUBLE) dx(*),dy(*),dtemp,c,s - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = c*dx(ix) + s*dy(iy) - dy(iy) = c*dy(iy) - s*dx(ix) - dx(ix) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - dtemp = c*dx(i) + s*dy(i) - dy(i) = c*dy(i) - s*dx(i) - dx(i) = dtemp - 30 continue - return - - END SUBROUTINE DROT - -! ################################################################################################################################## -! 011 LAPACK_BLAS_AUX - - SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY, col_num ) - -* .. Scalar Arguments .. - REAL(DOUBLE) ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N, col_num - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric band matrix, with k super-diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the band matrix A is being supplied as -* follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* being supplied. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* being supplied. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of super-diagonals of the -* matrix A. K must satisfy 0 .le. K. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL(DOUBLE). -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - REAL(DOUBLE) array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. - -! col_num - Integer -! The col num corresponding to the vector y being multiplied -! (for use when there are multiple calls to dsbmv to mult -! a matrix times each col of another matrix). -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( K.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN - -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array A -* are accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j,n,col_num,cr13_lba - ENDIF - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j,n,col_num,cr13_lba - ENDIF - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( 1, J ) - L = 1 - J - DO 90, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) - L = 1 - J - IX = JX - IY = JY - DO 110, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -12345 format(7X,'mult row ',i8,' of ',i8,' times col ',i8, a) - -* End of DSBMV . -* - END SUBROUTINE DSBMV - -! ################################################################################################################################## -! 014 LAPACK_BLAS_AUX - - SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) - -* .. Scalar Arguments .. - REAL(DOUBLE) ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL(DOUBLE). -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - REAL(DOUBLE) array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( J, J ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYMV . -* - END SUBROUTINE DSYMV - -! ################################################################################################################################## -! 015 LAPACK_BLAS_AUX - - SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) - -* .. Scalar Arguments .. - REAL(DOUBLE) ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DSYR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR . -* - END SUBROUTINE DSYR - -! ################################################################################################################################## -! 016 LAPACK_BLAS_AUX - - SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) - -* .. Scalar Arguments .. - REAL(DOUBLE) ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - REAL(DOUBLE) array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2 . -* - END SUBROUTINE DSYR2 - -! ################################################################################################################################## -! 017 LAPACK_BLAS_AUX - - SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) - -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - REAL(DOUBLE) ALPHA, BETA -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -* beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - REAL(DOUBLE) array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - REAL(DOUBLE). -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - REAL(DOUBLE) array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - REAL(DOUBLE) TEMP1, TEMP2 -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2K. -* - END SUBROUTINE DSYR2K - -! ################################################################################################################################## -! 018 LAPACK_BLAS_AUX - - SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) - -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - REAL(DOUBLE) ALPHA, BETA -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - REAL(DOUBLE). -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - REAL(DOUBLE) array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - REAL(DOUBLE) TEMP -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYRK . -* - END SUBROUTINE DSYRK - -! ################################################################################################################################## -! 019 LAPACK_BLAS_AUX - - SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX, - & dtbsv_msg ) ! my addition - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DTBSV' -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO - character*1 dtbsv_msg -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -! dtbsv_msg (input) CHARACTER -! = 'Y', have subr DTBSV print Fwd, Back pass messages -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* - - -! ********************************************************************************************************************************** -** Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTBSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - if (dtbsv_msg == 'Y' .AND. (NOCOUNTS .NE. 'Y')) then - write(sc1,22345,advance='no') j,cr13_lba - endif - IF( X( J ).NE.ZERO )THEN - L = KPLUS1 - J - IF( NOUNIT ) - $ X( J ) = X( J )/A( KPLUS1, J ) - TEMP = X( J ) - DO 10, I = J - 1, MAX( 1, J - K ), -1 - X( I ) = X( I ) - TEMP*A( L + I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 40, J = N, 1, -1 - if (dtbsv_msg == 'Y' .AND. (NOCOUNTS .NE. 'Y')) then - write(sc1,22345,advance='no') j,cr13_lba - endif - KX = KX - INCX - IF( X( JX ).NE.ZERO )THEN - IX = KX - L = KPLUS1 - J - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( KPLUS1, J ) - TEMP = X( JX ) - DO 30, I = J - 1, MAX( 1, J - K ), -1 - X( IX ) = X( IX ) - TEMP*A( L + I, J ) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - if (dtbsv_msg == 'Y' .and. (NOCOUNTS .NE. 'Y')) then - write(sc1,12345,advance='no') j,n,cr13_lba - endif - IF( X( J ).NE.ZERO )THEN - L = 1 - J - IF( NOUNIT ) - $ X( J ) = X( J )/A( 1, J ) - TEMP = X( J ) - DO 50, I = J + 1, MIN( N, J + K ) - X( I ) = X( I ) - TEMP*A( L + I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - if (dtbsv_msg == 'Y' .and. (NOCOUNTS .NE. 'Y')) then - write(sc1,12345,advance='no') j,n,cr13_lba - endif - KX = KX + INCX - IF( X( JX ).NE.ZERO )THEN - IX = KX - L = 1 - J - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( 1, J ) - TEMP = X( JX ) - DO 70, I = J + 1, MIN( N, J + K ) - X( IX ) = X( IX ) - TEMP*A( L + I, J ) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A')*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - if (dtbsv_msg == 'Y' .and. (NOCOUNTS .NE. 'Y')) then - write(sc1,12345,advance='no') j,n,cr13_lba - endif - TEMP = X( J ) - L = KPLUS1 - J - DO 90, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - if (dtbsv_msg == 'Y' .and. (NOCOUNTS .NE. 'Y')) then - write(sc1,12345,advance='no') j,n,cr13_lba - endif - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 110, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - X( JX ) = TEMP - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - if (dtbsv_msg == 'Y' .AND. (NOCOUNTS .NE. 'Y')) then - write(sc1,22345,advance='no') j,cr13_lba - endif - TEMP = X( J ) - L = 1 - J - DO 130, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( I ) - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - X( J ) = TEMP - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - if (dtbsv_msg == 'Y' .AND. (NOCOUNTS .NE. 'Y')) then - write(sc1,22345,advance='no') j,cr13_lba - endif - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 150, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - X( JX ) = TEMP - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -12345 format(7X,'Forward pass, row ',i8,' to ',i8, a) - -22345 format(7X,'Backward pass, row ',i8,' to 1 ', a) - -* End of DTBSV . -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DTBSV - -! ################################################################################################################################## -! 020 LAPACK_BLAS_AUX - - SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) - -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - REAL(DOUBLE) ALPHA -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ), -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - REAL(DOUBLE). -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - REAL(DOUBLE) array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - REAL(DOUBLE) TEMP -* .. Parameters .. - REAL(DOUBLE) ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B. -* - IF( UPPER )THEN - DO 110, J = 1, N - DO 100, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - B( I, J ) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 120, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 120 CONTINUE - B( I, J ) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 180, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 150 CONTINUE - DO 170, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 160, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 190, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 190 CONTINUE - DO 210, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 200, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A'. -* - IF( UPPER )THEN - DO 260, K = 1, N - DO 240, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 230, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 250, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300, K = N, 1, -1 - DO 280, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 270, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END SUBROUTINE DTRMM - -! ################################################################################################################################## -! 021 LAPACK_BLAS_AUX - - SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) - -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - REAL(DOUBLE) array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - REAL(DOUBLE) array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - REAL(DOUBLE) TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 110, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 130, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END SUBROUTINE DTRMV - -! ################################################################################################################################## -! 023 LAPACK_BLAS_AUX - - INTEGER FUNCTION IDAMAX(N,DX,INCX) - -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL(DOUBLE) dx(*),dmax - integer i,incx,ix,n -c - idamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - idamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.dmax) go to 5 - idamax = i - dmax = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.dmax) go to 30 - idamax = i - dmax = dabs(dx(i)) - 30 continue - return - - END FUNCTION IDAMAX - -! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -! Auxiliary routines - -! ################################################################################################################################## -! 024 LAPACK_BLAS_AUX - - SUBROUTINE DLABAD( SMALL, LARGE ) - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - REAL(DOUBLE) LARGE, SMALL -* .. -* -* Purpose -* ======= -* -* DLABAD takes as input the values computed by DLAMCH for underflow and -* overflow, and returns the square root of each of these values if the -* log of LARGE is sufficiently large. This subroutine is intended to -* identify machines with a large exponent range, such as the Crays, and -* redefine the underflow and overflow limits to be the square roots of -* the values computed by DLAMCH. This subroutine is needed because -* DLAMCH does not compensate for poor arithmetic in the upper half of -* the exponent range, as is found on a Cray. -* -* Arguments -* ========= -* -* SMALL (input/output) REAL(DOUBLE) -* On entry, the underflow threshold as computed by DLAMCH. -* On exit, if LOG10(LARGE) is sufficiently large, the square -* root of SMALL, otherwise unchanged. -* -* LARGE (input/output) REAL(DOUBLE) -* On entry, the overflow threshold as computed by DLAMCH. -* On exit, if LOG10(LARGE) is sufficiently large, the square -* root of LARGE, otherwise unchanged. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LOG10, SQRT -* .. -* .. Executable Statements .. -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - IF( LOG10( LARGE ).GT.2000.D0 ) THEN - SMALL = SQRT( SMALL ) - LARGE = SQRT( LARGE ) - END IF -* - RETURN -* -* End of DLABAD -* - END SUBROUTINE DLABAD - -! ################################################################################################################################## -! 025 LAPACK_BLAS_AUX - - SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE, itmax ) ! My itmax - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DLACON' - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER KASE, N - integer itmax - REAL(DOUBLE) EST -* .. -* .. Array Arguments .. - INTEGER ISGN( * ) - REAL(DOUBLE) V( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DLACON estimates the 1-norm of a square, real matrix A. -* Reverse communication is used for evaluating matrix-vector products. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix. N >= 1. -* -* V (workspace) REAL(DOUBLE) array, dimension (N) -* On the final return, V = A*W, where EST = norm(V)/norm(W) -* (W is not returned). -* -* X (input/output) REAL(DOUBLE) array, dimension (N) -* On an intermediate return, X should be overwritten by -* A * X, if KASE=1, -* A' * X, if KASE=2, -* and DLACON must be re-called with all the other parameters -* unchanged. -* -* ISGN (workspace) INTEGER array, dimension (N) -* -* EST (output) REAL(DOUBLE) -* An estimate (a lower bound) for norm(A). -* -* KASE (input/output) INTEGER -* On the initial call to DLACON, KASE should be 0. -* On an intermediate return, KASE will be 1 or 2, indicating -* whether X should be overwritten by A * X or A' * X. -* On the final return from DLACON, KASE will again be 0. - -! itmax (input) INTEGER -! Max number of iterations. (NOTE: this was a local scalar in the -! original DLACON, but I made it an input variable) -* -* Further Details -* ======= ======= -* -* Contributed by Nick Higham, University of Manchester. -* Originally named SONEST, dated March 16, 1988. -* -* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of -* a real or complex matrix, with applications to condition estimation", -* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, ITER, J, JLAST, JUMP - REAL(DOUBLE) ALTSGN, ESTOLD, TEMP -* .. -* .. External Functions .. -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, NINT, SIGN -* .. -* .. Save statement .. - SAVE -* .. -* .. Executable Statements .. -* - - -! ********************************************************************************************************************************** - IF( KASE.EQ.0 ) THEN - DO 10 I = 1, N - X( I ) = ONE / DBLE( N ) - 10 CONTINUE - KASE = 1 - JUMP = 1 - RETURN - END IF -* - GO TO ( 20, 40, 70, 110, 140 )JUMP -* -* ................ ENTRY (JUMP = 1) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. -* - 20 CONTINUE - IF( N.EQ.1 ) THEN - V( 1 ) = X( 1 ) - EST = ABS( V( 1 ) ) -* ... QUIT - GO TO 150 - END IF - EST = DASUM( N, X, 1 ) -* - DO 30 I = 1, N - X( I ) = SIGN( ONE, X( I ) ) - ISGN( I ) = NINT( X( I ) ) - 30 CONTINUE - KASE = 2 - JUMP = 2 - RETURN -* -* ................ ENTRY (JUMP = 2) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. -* - 40 CONTINUE - J = IDAMAX( N, X, 1 ) - ITER = 2 -* -* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. -* - 50 CONTINUE - DO 60 I = 1, N - X( I ) = ZERO - 60 CONTINUE - X( J ) = ONE - KASE = 1 - JUMP = 3 - RETURN -* -* ................ ENTRY (JUMP = 3) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 70 CONTINUE - CALL DCOPY( N, X, 1, V, 1 ) - ESTOLD = EST - EST = DASUM( N, V, 1 ) - DO 80 I = 1, N - IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) - $ GO TO 90 - 80 CONTINUE -* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. - GO TO 120 -* - 90 CONTINUE -* TEST FOR CYCLING. - IF( EST.LE.ESTOLD ) - $ GO TO 120 -* - DO 100 I = 1, N - X( I ) = SIGN( ONE, X( I ) ) - ISGN( I ) = NINT( X( I ) ) - 100 CONTINUE - KASE = 2 - JUMP = 4 - RETURN -* -* ................ ENTRY (JUMP = 4) -* X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. -* - 110 CONTINUE - JLAST = J - J = IDAMAX( N, X, 1 ) - IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN - ITER = ITER + 1 - GO TO 50 - END IF -* -* ITERATION COMPLETE. FINAL STAGE. -* - 120 CONTINUE - ALTSGN = ONE - DO 130 I = 1, N - X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) - ALTSGN = -ALTSGN - 130 CONTINUE - KASE = 1 - JUMP = 5 - RETURN -* -* ................ ENTRY (JUMP = 5) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 140 CONTINUE - TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) - IF( TEMP.GT.EST ) THEN - CALL DCOPY( N, X, 1, V, 1 ) - EST = TEMP - END IF -* - 150 CONTINUE - KASE = 0 -* -* End of DLACON -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DLACON - -! ################################################################################################################################## -! 026 LAPACK_BLAS_AUX - - SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DLACPY copies all or part of a two-dimensional matrix A to another -* matrix B. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies the part of the matrix A to be copied to B. -* = 'U': Upper triangular part -* = 'L': Lower triangular part -* Otherwise: All of the matrix A -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input) REAL(DOUBLE) array, dimension (LDA,N) -* The m by n matrix A. If UPLO = 'U', only the upper triangle -* or trapezoid is accessed; if UPLO = 'L', only the lower -* triangle or trapezoid is accessed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* B (output) REAL(DOUBLE) array, dimension (LDB,N) -* On exit, B = A in the locations specified by UPLO. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,M). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B( I, J ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B( I, J ) = A( I, J ) - 30 CONTINUE - 40 CONTINUE - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B( I, J ) = A( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF - RETURN -* -* End of DLACPY -* - END SUBROUTINE DLACPY - -! ################################################################################################################################## -! 027 LAPACK_BLAS_AUX - - SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - REAL(DOUBLE) A, B, C, RT1, RT2 -* .. -* -* Purpose -* ======= -* -* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix -* [ A B ] -* [ B C ]. -* On return, RT1 is the eigenvalue of larger absolute value, and RT2 -* is the eigenvalue of smaller absolute value. -* -* Arguments -* ========= -* -* A (input) REAL(DOUBLE) -* The (1,1) element of the 2-by-2 matrix. -* -* B (input) REAL(DOUBLE) -* The (1,2) and (2,1) elements of the 2-by-2 matrix. -* -* C (input) REAL(DOUBLE) -* The (2,2) element of the 2-by-2 matrix. -* -* RT1 (output) REAL(DOUBLE) -* The eigenvalue of larger absolute value. -* -* RT2 (output) REAL(DOUBLE) -* The eigenvalue of smaller absolute value. -* -* Further Details -* =============== -* -* RT1 is accurate to a few ulps barring over/underflow. -* -* RT2 may be inaccurate if there is massive cancellation in the -* determinant A*C-B*B; higher precision or correctly rounded or -* correctly truncated arithmetic would be needed to compute RT2 -* accurately in all cases. -* -* Overflow is possible only if RT1 is within a factor of 5 of overflow. -* Underflow is harmless if the input data is 0 or exceeds -* underflow_threshold / macheps. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D0 ) - REAL(DOUBLE) TWO - PARAMETER ( TWO = 2.0D0 ) - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D0 ) - REAL(DOUBLE) HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - REAL(DOUBLE) AB, ACMN, ACMX, ADF, DF, RT, SM, TB -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* -* Compute the eigenvalues -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* Includes case AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* Includes case RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - END IF - RETURN -* -* End of DLAE2 -* - END SUBROUTINE DLAE2 - -! ################################################################################################################################## -! 028 LAPACK_BLAS_AUX - - SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, - $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, - $ NAB, WORK, IWORK, INFO ) - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX - REAL(DOUBLE) ABSTOL, PIVMIN, RELTOL -* .. -* .. Array Arguments .. - INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) - REAL(DOUBLE) AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), - $ WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLAEBZ contains the iteration loops which compute and use the -* function N(w), which is the count of eigenvalues of a symmetric -* tridiagonal matrix T less than or equal to its argument w. It -* performs a choice of two types of loops: -* -* IJOB=1, followed by -* IJOB=2: It takes as input a list of intervals and returns a list of -* sufficiently small intervals whose union contains the same -* eigenvalues as the union of the original intervals. -* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. -* The output interval (AB(j,1),AB(j,2)] will contain -* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. -* -* IJOB=3: It performs a binary search in each input interval -* (AB(j,1),AB(j,2)] for a point w(j) such that -* N(w(j))=NVAL(j), and uses C(j) as the starting point of -* the search. If such a w(j) is found, then on output -* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output -* (AB(j,1),AB(j,2)] will be a small interval containing the -* point where N(w) jumps through NVAL(j), unless that point -* lies outside the initial interval. -* -* Note that the intervals are in all cases half-open intervals, -* i.e., of the form (a,b] , which includes b but not a . -* -* To avoid underflow, the matrix should be scaled so that its largest -* element is no greater than overflow**(1/2) * underflow**(1/4) -* in absolute value. To assure the most accurate computation -* of small eigenvalues, the matrix should be scaled to be -* not much smaller than that, either. -* -* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal -* Matrix", Report CS41, Computer Science Dept., Stanford -* University, July 21, 1966 -* -* Note: the arguments are, in general, *not* checked for unreasonable -* values. -* -* Arguments -* ========= -* -* IJOB (input) INTEGER -* Specifies what is to be done: -* = 1: Compute NAB for the initial intervals. -* = 2: Perform bisection iteration to find eigenvalues of T. -* = 3: Perform bisection iteration to invert N(w), i.e., -* to find a point which has a specified number of -* eigenvalues of T to its left. -* Other values will cause DLAEBZ to return with INFO=-1. -* -* NITMAX (input) INTEGER -* The maximum number of "levels" of bisection to be -* performed, i.e., an interval of width W will not be made -* smaller than 2^(-NITMAX) * W. If not all intervals -* have converged after NITMAX iterations, then INFO is set -* to the number of non-converged intervals. -* -* N (input) INTEGER -* The dimension n of the tridiagonal matrix T. It must be at -* least 1. -* -* MMAX (input) INTEGER -* The maximum number of intervals. If more than MMAX intervals -* are generated, then DLAEBZ will quit with INFO=MMAX+1. -* -* MINP (input) INTEGER -* The initial number of intervals. It may not be greater than -* MMAX. -* -* NBMIN (input) INTEGER -* The smallest number of intervals that should be processed -* using a vector loop. If zero, then only the scalar loop -* will be used. -* -* ABSTOL (input) REAL(DOUBLE) -* The minimum (absolute) width of an interval. When an -* interval is narrower than ABSTOL, or than RELTOL times the -* larger (in magnitude) endpoint, then it is considered to be -* sufficiently small, i.e., converged. This must be at least -* zero. -* -* RELTOL (input) REAL(DOUBLE) -* The minimum relative width of an interval. When an interval -* is narrower than ABSTOL, or than RELTOL times the larger (in -* magnitude) endpoint, then it is considered to be -* sufficiently small, i.e., converged. Note: this should -* always be at least radix*machine epsilon. -* -* PIVMIN (input) REAL(DOUBLE) -* The minimum absolute value of a "pivot" in the Sturm -* sequence loop. This *must* be at least max |e(j)**2| * -* safe_min and at least safe_min, where safe_min is at least -* the smallest number that can divide one without overflow. -* -* D (input) REAL(DOUBLE) array, dimension (N) -* The diagonal elements of the tridiagonal matrix T. -* -* E (input) REAL(DOUBLE) array, dimension (N) -* The offdiagonal elements of the tridiagonal matrix T in -* positions 1 through N-1. E(N) is arbitrary. -* -* E2 (input) REAL(DOUBLE) array, dimension (N) -* The squares of the offdiagonal elements of the tridiagonal -* matrix T. E2(N) is ignored. -* -* NVAL (input/output) INTEGER array, dimension (MINP) -* If IJOB=1 or 2, not referenced. -* If IJOB=3, the desired values of N(w). The elements of NVAL -* will be reordered to correspond with the intervals in AB. -* Thus, NVAL(j) on output will not, in general be the same as -* NVAL(j) on input, but it will correspond with the interval -* (AB(j,1),AB(j,2)] on output. -* -* AB (input/output) REAL(DOUBLE) array, dimension (MMAX,2) -* The endpoints of the intervals. AB(j,1) is a(j), the left -* endpoint of the j-th interval, and AB(j,2) is b(j), the -* right endpoint of the j-th interval. The input intervals -* will, in general, be modified, split, and reordered by the -* calculation. -* -* C (input/output) REAL(DOUBLE) array, dimension (MMAX) -* If IJOB=1, ignored. -* If IJOB=2, workspace. -* If IJOB=3, then on input C(j) should be initialized to the -* first search point in the binary search. -* -* MOUT (output) INTEGER -* If IJOB=1, the number of eigenvalues in the intervals. -* If IJOB=2 or 3, the number of intervals output. -* If IJOB=3, MOUT will equal MINP. -* -* NAB (input/output) INTEGER array, dimension (MMAX,2) -* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). -* If IJOB=2, then on input, NAB(i,j) should be set. It must -* satisfy the condition: -* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), -* which means that in interval i only eigenvalues -* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, -* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with -* IJOB=1. -* On output, NAB(i,j) will contain -* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of -* the input interval that the output interval -* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the -* the input values of NAB(k,1) and NAB(k,2). -* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), -* unless N(w) > NVAL(i) for all search points w , in which -* case NAB(i,1) will not be modified, i.e., the output -* value will be the same as the input value (modulo -* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) -* for all search points w , in which case NAB(i,2) will -* not be modified. Normally, NAB should be set to some -* distinctive value(s) before DLAEBZ is called. -* -* WORK (workspace) REAL(DOUBLE) array, dimension (MMAX) -* Workspace. -* -* IWORK (workspace) INTEGER array, dimension (MMAX) -* Workspace. -* -* INFO (output) INTEGER -* = 0: All intervals converged. -* = 1--MMAX: The last INFO intervals did not converge. -* = MMAX+1: More than MMAX intervals were generated. -* -* Further Details -* =============== -* -* This routine is intended to be called only by other LAPACK -* routines, thus the interface is less user-friendly. It is intended -* for two purposes: -* -* (a) finding eigenvalues. In this case, DLAEBZ should have one or -* more initial intervals set up in AB, and DLAEBZ should be called -* with IJOB=1. This sets up NAB, and also counts the eigenvalues. -* Intervals with no eigenvalues would usually be thrown out at -* this point. Also, if not all the eigenvalues in an interval i -* are desired, NAB(i,1) can be increased or NAB(i,2) decreased. -* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest -* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX -* no smaller than the value of MOUT returned by the call with -* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 -* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the -* tolerance specified by ABSTOL and RELTOL. -* -* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). -* In this case, start with a Gershgorin interval (a,b). Set up -* AB to contain 2 search intervals, both initially (a,b). One -* NVAL element should contain f-1 and the other should contain l -* , while C should contain a and b, resp. NAB(i,1) should be -1 -* and NAB(i,2) should be N+1, to flag an error if the desired -* interval does not lie in (a,b). DLAEBZ is then called with -* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- -* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while -* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r -* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and -* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and -* w(l-r)=...=w(l+k) are handled similarly. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, TWO, HALF - PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, - $ HALF = 1.0D0 / TWO ) -* .. -* .. Local Scalars .. - INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, - $ KLNEW - REAL(DOUBLE) TMP1, TMP2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* -* Check for Errors -* - INFO = 0 - IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN - INFO = -1 - RETURN - END IF -* -* Initialize NAB -* - IF( IJOB.EQ.1 ) THEN -* -* Compute the number of eigenvalues in the initial intervals. -* - MOUT = 0 -*DIR$ NOVECTOR - DO 30 JI = 1, MINP - DO 20 JP = 1, 2 - TMP1 = D( 1 ) - AB( JI, JP ) - IF( ABS( TMP1 ).LT.PIVMIN ) - $ TMP1 = -PIVMIN - NAB( JI, JP ) = 0 - IF( TMP1.LE.ZERO ) - $ NAB( JI, JP ) = 1 -* - DO 10 J = 2, N - TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP ) - IF( ABS( TMP1 ).LT.PIVMIN ) - $ TMP1 = -PIVMIN - IF( TMP1.LE.ZERO ) - $ NAB( JI, JP ) = NAB( JI, JP ) + 1 - 10 CONTINUE - 20 CONTINUE - MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 ) - 30 CONTINUE - RETURN - END IF -* -* Initialize for loop -* -* KF and KL have the following meaning: -* Intervals 1,...,KF-1 have converged. -* Intervals KF,...,KL still need to be refined. -* - KF = 1 - KL = MINP -* -* If IJOB=2, initialize C. -* If IJOB=3, use the user-supplied starting point. -* - IF( IJOB.EQ.2 ) THEN - DO 40 JI = 1, MINP - C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) - 40 CONTINUE - END IF -* -* Iteration loop -* - DO 130 JIT = 1, NITMAX -* -* Loop over intervals -* - IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN -* -* Begin of Parallel Version of the loop -* - DO 60 JI = KF, KL -* -* Compute N(c), the number of eigenvalues less than c -* - WORK( JI ) = D( 1 ) - C( JI ) - IWORK( JI ) = 0 - IF( WORK( JI ).LE.PIVMIN ) THEN - IWORK( JI ) = 1 - WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) - END IF -* - DO 50 J = 2, N - WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI ) - IF( WORK( JI ).LE.PIVMIN ) THEN - IWORK( JI ) = IWORK( JI ) + 1 - WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) - END IF - 50 CONTINUE - 60 CONTINUE -* - IF( IJOB.LE.2 ) THEN -* -* IJOB=2: Choose all intervals containing eigenvalues. -* - KLNEW = KL - DO 70 JI = KF, KL -* -* Insure that N(w) is monotone -* - IWORK( JI ) = MIN( NAB( JI, 2 ), - $ MAX( NAB( JI, 1 ), IWORK( JI ) ) ) -* -* Update the Queue -- add intervals if both halves -* contain eigenvalues. -* - IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN -* -* No eigenvalue in the upper interval: -* just use the lower interval. -* - AB( JI, 2 ) = C( JI ) -* - ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN -* -* No eigenvalue in the lower interval: -* just use the upper interval. -* - AB( JI, 1 ) = C( JI ) - ELSE - KLNEW = KLNEW + 1 - IF( KLNEW.LE.MMAX ) THEN -* -* Eigenvalue in both intervals -- add upper to -* queue. -* - AB( KLNEW, 2 ) = AB( JI, 2 ) - NAB( KLNEW, 2 ) = NAB( JI, 2 ) - AB( KLNEW, 1 ) = C( JI ) - NAB( KLNEW, 1 ) = IWORK( JI ) - AB( JI, 2 ) = C( JI ) - NAB( JI, 2 ) = IWORK( JI ) - ELSE - INFO = MMAX + 1 - END IF - END IF - 70 CONTINUE - IF( INFO.NE.0 ) - $ RETURN - KL = KLNEW - ELSE -* -* IJOB=3: Binary search. Keep only the interval containing -* w s.t. N(w) = NVAL -* - DO 80 JI = KF, KL - IF( IWORK( JI ).LE.NVAL( JI ) ) THEN - AB( JI, 1 ) = C( JI ) - NAB( JI, 1 ) = IWORK( JI ) - END IF - IF( IWORK( JI ).GE.NVAL( JI ) ) THEN - AB( JI, 2 ) = C( JI ) - NAB( JI, 2 ) = IWORK( JI ) - END IF - 80 CONTINUE - END IF -* - ELSE -* -* End of Parallel Version of the loop -* -* Begin of Serial Version of the loop -* - KLNEW = KL - DO 100 JI = KF, KL -* -* Compute N(w), the number of eigenvalues less than w -* - TMP1 = C( JI ) - TMP2 = D( 1 ) - TMP1 - ITMP1 = 0 - IF( TMP2.LE.PIVMIN ) THEN - ITMP1 = 1 - TMP2 = MIN( TMP2, -PIVMIN ) - END IF -* -* A series of compiler directives to defeat vectorization -* for the next loop -* -*$PL$ CMCHAR=' ' -CDIR$ NEXTSCALAR -C$DIR SCALAR -CDIR$ NEXT SCALAR -CVD$L NOVECTOR -CDEC$ NOVECTOR -CVD$ NOVECTOR -*VDIR NOVECTOR -*VOCL LOOP,SCALAR -CIBM PREFER SCALAR -*$PL$ CMCHAR='*' -* - DO 90 J = 2, N - TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1 - IF( TMP2.LE.PIVMIN ) THEN - ITMP1 = ITMP1 + 1 - TMP2 = MIN( TMP2, -PIVMIN ) - END IF - 90 CONTINUE -* - IF( IJOB.LE.2 ) THEN -* -* IJOB=2: Choose all intervals containing eigenvalues. -* -* Insure that N(w) is monotone -* - ITMP1 = MIN( NAB( JI, 2 ), - $ MAX( NAB( JI, 1 ), ITMP1 ) ) -* -* Update the Queue -- add intervals if both halves -* contain eigenvalues. -* - IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN -* -* No eigenvalue in the upper interval: -* just use the lower interval. -* - AB( JI, 2 ) = TMP1 -* - ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN -* -* No eigenvalue in the lower interval: -* just use the upper interval. -* - AB( JI, 1 ) = TMP1 - ELSE IF( KLNEW.LT.MMAX ) THEN -* -* Eigenvalue in both intervals -- add upper to queue. -* - KLNEW = KLNEW + 1 - AB( KLNEW, 2 ) = AB( JI, 2 ) - NAB( KLNEW, 2 ) = NAB( JI, 2 ) - AB( KLNEW, 1 ) = TMP1 - NAB( KLNEW, 1 ) = ITMP1 - AB( JI, 2 ) = TMP1 - NAB( JI, 2 ) = ITMP1 - ELSE - INFO = MMAX + 1 - RETURN - END IF - ELSE -* -* IJOB=3: Binary search. Keep only the interval -* containing w s.t. N(w) = NVAL -* - IF( ITMP1.LE.NVAL( JI ) ) THEN - AB( JI, 1 ) = TMP1 - NAB( JI, 1 ) = ITMP1 - END IF - IF( ITMP1.GE.NVAL( JI ) ) THEN - AB( JI, 2 ) = TMP1 - NAB( JI, 2 ) = ITMP1 - END IF - END IF - 100 CONTINUE - KL = KLNEW -* -* End of Serial Version of the loop -* - END IF -* -* Check for convergence -* - KFNEW = KF - DO 110 JI = KF, KL - TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) ) - TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) ) - IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. - $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN -* -* Converged -- Swap with position KFNEW, -* then increment KFNEW -* - IF( JI.GT.KFNEW ) THEN - TMP1 = AB( JI, 1 ) - TMP2 = AB( JI, 2 ) - ITMP1 = NAB( JI, 1 ) - ITMP2 = NAB( JI, 2 ) - AB( JI, 1 ) = AB( KFNEW, 1 ) - AB( JI, 2 ) = AB( KFNEW, 2 ) - NAB( JI, 1 ) = NAB( KFNEW, 1 ) - NAB( JI, 2 ) = NAB( KFNEW, 2 ) - AB( KFNEW, 1 ) = TMP1 - AB( KFNEW, 2 ) = TMP2 - NAB( KFNEW, 1 ) = ITMP1 - NAB( KFNEW, 2 ) = ITMP2 - IF( IJOB.EQ.3 ) THEN - ITMP1 = NVAL( JI ) - NVAL( JI ) = NVAL( KFNEW ) - NVAL( KFNEW ) = ITMP1 - END IF - END IF - KFNEW = KFNEW + 1 - END IF - 110 CONTINUE - KF = KFNEW -* -* Choose Midpoints -* - DO 120 JI = KF, KL - C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) - 120 CONTINUE -* -* If no more intervals to refine, quit. -* - IF( KF.GT.KL ) - $ GO TO 140 - 130 CONTINUE -* -* Converged -* - 140 CONTINUE - INFO = MAX( KL+1-KF, 0 ) - MOUT = KL -* - RETURN -* -* End of DLAEBZ -* - END SUBROUTINE DLAEBZ - -! ################################################################################################################################## -! 029 LAPACK_BLAS_AUX - - SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - REAL(DOUBLE) A, B, C, CS1, RT1, RT2, SN1 -* .. -* -* Purpose -* ======= -* -* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix -* [ A B ] -* [ B C ]. -* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the -* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right -* eigenvector for RT1, giving the decomposition -* -* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] -* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. -* -* Arguments -* ========= -* -* A (input) REAL(DOUBLE) -* The (1,1) element of the 2-by-2 matrix. -* -* B (input) REAL(DOUBLE) -* The (1,2) element and the conjugate of the (2,1) element of -* the 2-by-2 matrix. -* -* C (input) REAL(DOUBLE) -* The (2,2) element of the 2-by-2 matrix. -* -* RT1 (output) REAL(DOUBLE) -* The eigenvalue of larger absolute value. -* -* RT2 (output) REAL(DOUBLE) -* The eigenvalue of smaller absolute value. -* -* CS1 (output) REAL(DOUBLE) -* SN1 (output) REAL(DOUBLE) -* The vector (CS1, SN1) is a unit right eigenvector for RT1. -* -* Further Details -* =============== -* -* RT1 is accurate to a few ulps barring over/underflow. -* -* RT2 may be inaccurate if there is massive cancellation in the -* determinant A*C-B*B; higher precision or correctly rounded or -* correctly truncated arithmetic would be needed to compute RT2 -* accurately in all cases. -* -* CS1 and SN1 are accurate to a few ulps barring over/underflow. -* -* Overflow is possible only if RT1 is within a factor of 5 of overflow. -* Underflow is harmless if the input data is 0 or exceeds -* underflow_threshold / macheps. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D0 ) - REAL(DOUBLE) TWO - PARAMETER ( TWO = 2.0D0 ) - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D0 ) - REAL(DOUBLE) HALF - PARAMETER ( HALF = 0.5D0 ) -* .. -* .. Local Scalars .. - INTEGER SGN1, SGN2 - REAL(DOUBLE) AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, - $ TB, TN -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* -* Compute the eigenvalues -* - SM = A + C - DF = A - C - ADF = ABS( DF ) - TB = B + B - AB = ABS( TB ) - IF( ABS( A ).GT.ABS( C ) ) THEN - ACMX = A - ACMN = C - ELSE - ACMX = C - ACMN = A - END IF - IF( ADF.GT.AB ) THEN - RT = ADF*SQRT( ONE+( AB / ADF )**2 ) - ELSE IF( ADF.LT.AB ) THEN - RT = AB*SQRT( ONE+( ADF / AB )**2 ) - ELSE -* -* Includes case AB=ADF=0 -* - RT = AB*SQRT( TWO ) - END IF - IF( SM.LT.ZERO ) THEN - RT1 = HALF*( SM-RT ) - SGN1 = -1 -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE IF( SM.GT.ZERO ) THEN - RT1 = HALF*( SM+RT ) - SGN1 = 1 -* -* Order of execution important. -* To get fully accurate smaller eigenvalue, -* next line needs to be executed in higher precision. -* - RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B - ELSE -* -* Includes case RT1 = RT2 = 0 -* - RT1 = HALF*RT - RT2 = -HALF*RT - SGN1 = 1 - END IF -* -* Compute the eigenvector -* - IF( DF.GE.ZERO ) THEN - CS = DF + RT - SGN2 = 1 - ELSE - CS = DF - RT - SGN2 = -1 - END IF - ACS = ABS( CS ) - IF( ACS.GT.AB ) THEN - CT = -TB / CS - SN1 = ONE / SQRT( ONE+CT*CT ) - CS1 = CT*SN1 - ELSE - IF( AB.EQ.ZERO ) THEN - CS1 = ONE - SN1 = ZERO - ELSE - TN = -CS / TB - CS1 = ONE / SQRT( ONE+TN*TN ) - SN1 = TN*CS1 - END IF - END IF - IF( SGN1.EQ.SGN2 ) THEN - TN = CS1 - CS1 = -SN1 - SN1 = TN - END IF - RETURN -* -* End of DLAEV2 -* - END SUBROUTINE DLAEV2 - -! ################################################################################################################################## -! 030 LAPACK_BLAS_AUX - - SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, JOB, N - REAL(DOUBLE) TOL -* .. -* .. Array Arguments .. - INTEGER IN( * ) - REAL(DOUBLE) A( * ), B( * ), C( * ), D( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DLAGTS may be used to solve one of the systems of equations -* -* (T - lambda*I)*x = y or (T - lambda*I)'*x = y, -* -* where T is an n by n tridiagonal matrix, for x, following the -* factorization of (T - lambda*I) as -* -* (T - lambda*I) = P*L*U , -* -* by routine DLAGTF. The choice of equation to be solved is -* controlled by the argument JOB, and in each case there is an option -* to perturb zero or very small diagonal elements of U, this option -* being intended for use in applications such as inverse iteration. -* -* Arguments -* ========= -* -* JOB (input) INTEGER -* Specifies the job to be performed by DLAGTS as follows: -* = 1: The equations (T - lambda*I)x = y are to be solved, -* but diagonal elements of U are not to be perturbed. -* = -1: The equations (T - lambda*I)x = y are to be solved -* and, if overflow would otherwise occur, the diagonal -* elements of U are to be perturbed. See argument TOL -* below. -* = 2: The equations (T - lambda*I)'x = y are to be solved, -* but diagonal elements of U are not to be perturbed. -* = -2: The equations (T - lambda*I)'x = y are to be solved -* and, if overflow would otherwise occur, the diagonal -* elements of U are to be perturbed. See argument TOL -* below. -* -* N (input) INTEGER -* The order of the matrix T. -* -* A (input) REAL(DOUBLE) array, dimension (N) -* On entry, A must contain the diagonal elements of U as -* returned from DLAGTF. -* -* B (input) REAL(DOUBLE) array, dimension (N-1) -* On entry, B must contain the first super-diagonal elements of -* U as returned from DLAGTF. -* -* C (input) REAL(DOUBLE) array, dimension (N-1) -* On entry, C must contain the sub-diagonal elements of L as -* returned from DLAGTF. -* -* D (input) REAL(DOUBLE) array, dimension (N-2) -* On entry, D must contain the second super-diagonal elements -* of U as returned from DLAGTF. -* -* IN (input) INTEGER array, dimension (N) -* On entry, IN must contain details of the matrix P as returned -* from DLAGTF. -* -* Y (input/output) REAL(DOUBLE) array, dimension (N) -* On entry, the right hand side vector y. -* On exit, Y is overwritten by the solution vector x. -* -* TOL (input/output) REAL(DOUBLE) -* On entry, with JOB .lt. 0, TOL should be the minimum -* perturbation to be made to very small diagonal elements of U. -* TOL should normally be chosen as about eps*norm(U), where eps -* is the relative machine precision, but if TOL is supplied as -* non-positive, then it is reset to eps*max( abs( u(i,j) ) ). -* If JOB .gt. 0 then TOL is not referenced. -* -* On exit, TOL is changed as described above, only if TOL is -* non-positive on entry. Otherwise TOL is unchanged. -* -* INFO (output) INTEGER -* = 0 : successful exit -* .lt. 0: if INFO = -i, the i-th argument had an illegal value -* .gt. 0: overflow would occur when computing the INFO(th) -* element of the solution vector x. This can only occur -* when JOB is supplied as positive and either means -* that a diagonal element of U is very small, or that -* the elements of the right-hand side vector y are very -* large. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER K - REAL(DOUBLE) ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN -* .. -* .. External Functions .. - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. -* .. -* .. Executable Statements .. -* - INFO = 0 - IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAGTS', -INFO ) - RETURN - END IF -* - IF( N.EQ.0 ) - $ RETURN -* - EPS = DLAMCH( 'Epsilon' ) - SFMIN = DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SFMIN -* - IF( JOB.LT.0 ) THEN - IF( TOL.LE.ZERO ) THEN - TOL = ABS( A( 1 ) ) - IF( N.GT.1 ) - $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) ) - DO 10 K = 3, N - TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), - $ ABS( D( K-2 ) ) ) - 10 CONTINUE - TOL = TOL*EPS - IF( TOL.EQ.ZERO ) - $ TOL = EPS - END IF - END IF -* - IF( ABS( JOB ).EQ.1 ) THEN - DO 20 K = 2, N - IF( IN( K-1 ).EQ.0 ) THEN - Y( K ) = Y( K ) - C( K-1 )*Y( K-1 ) - ELSE - TEMP = Y( K-1 ) - Y( K-1 ) = Y( K ) - Y( K ) = TEMP - C( K-1 )*Y( K ) - END IF - 20 CONTINUE - IF( JOB.EQ.1 ) THEN - DO 30 K = N, 1, -1 - IF( K.LE.N-2 ) THEN - TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) - ELSE IF( K.EQ.N-1 ) THEN - TEMP = Y( K ) - B( K )*Y( K+1 ) - ELSE - TEMP = Y( K ) - END IF - AK = A( K ) - ABSAK = ABS( AK ) - IF( ABSAK.LT.ONE ) THEN - IF( ABSAK.LT.SFMIN ) THEN - IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) - $ THEN - INFO = K - RETURN - ELSE - TEMP = TEMP*BIGNUM - AK = AK*BIGNUM - END IF - ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN - INFO = K - RETURN - END IF - END IF - Y( K ) = TEMP / AK - 30 CONTINUE - ELSE - DO 50 K = N, 1, -1 - IF( K.LE.N-2 ) THEN - TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) - ELSE IF( K.EQ.N-1 ) THEN - TEMP = Y( K ) - B( K )*Y( K+1 ) - ELSE - TEMP = Y( K ) - END IF - AK = A( K ) - PERT = SIGN( TOL, AK ) - 40 CONTINUE - ABSAK = ABS( AK ) - IF( ABSAK.LT.ONE ) THEN - IF( ABSAK.LT.SFMIN ) THEN - IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) - $ THEN - AK = AK + PERT - PERT = 2*PERT - GO TO 40 - ELSE - TEMP = TEMP*BIGNUM - AK = AK*BIGNUM - END IF - ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN - AK = AK + PERT - PERT = 2*PERT - GO TO 40 - END IF - END IF - Y( K ) = TEMP / AK - 50 CONTINUE - END IF - ELSE -* -* Come to here if JOB = 2 or -2 -* - IF( JOB.EQ.2 ) THEN - DO 60 K = 1, N - IF( K.GE.3 ) THEN - TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) - ELSE IF( K.EQ.2 ) THEN - TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - ELSE - TEMP = Y( K ) - END IF - AK = A( K ) - ABSAK = ABS( AK ) - IF( ABSAK.LT.ONE ) THEN - IF( ABSAK.LT.SFMIN ) THEN - IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) - $ THEN - INFO = K - RETURN - ELSE - TEMP = TEMP*BIGNUM - AK = AK*BIGNUM - END IF - ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN - INFO = K - RETURN - END IF - END IF - Y( K ) = TEMP / AK - 60 CONTINUE - ELSE - DO 80 K = 1, N - IF( K.GE.3 ) THEN - TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) - ELSE IF( K.EQ.2 ) THEN - TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - ELSE - TEMP = Y( K ) - END IF - AK = A( K ) - PERT = SIGN( TOL, AK ) - 70 CONTINUE - ABSAK = ABS( AK ) - IF( ABSAK.LT.ONE ) THEN - IF( ABSAK.LT.SFMIN ) THEN - IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) - $ THEN - AK = AK + PERT - PERT = 2*PERT - GO TO 70 - ELSE - TEMP = TEMP*BIGNUM - AK = AK*BIGNUM - END IF - ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN - AK = AK + PERT - PERT = 2*PERT - GO TO 70 - END IF - END IF - Y( K ) = TEMP / AK - 80 CONTINUE - END IF -* - DO 90 K = N, 2, -1 - IF( IN( K-1 ).EQ.0 ) THEN - Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K ) - ELSE - TEMP = Y( K-1 ) - Y( K-1 ) = Y( K ) - Y( K ) = TEMP - C( K-1 )*Y( K ) - END IF - 90 CONTINUE - END IF -* -* End of DLAGTS -* - END SUBROUTINE DLAGTS - -! ################################################################################################################################## -! 032 LAPACK_BLAS_AUX -* - SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE1, RND - INTEGER BETA, T -* .. -* -* Purpose -* ======= -* -* DLAMC1 determines the machine parameters given by BETA, T, RND, and -* IEEE1. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* IEEE1 (output) LOGICAL -* Specifies whether rounding appears to be done in the IEEE -* 'round to nearest' style. -* -* Further Details -* =============== -* -* The routine is based on the routine ENVRON by Malcolm and -* incorporates suggestions by Gentleman and Marovich. See -* -* Malcolm M. A. (1972) Algorithms to reveal properties of -* floating-point arithmetic. Comms. of the ACM, 15, 949-951. -* -* Gentleman W. M. and Marovich S. B. (1974) More on algorithms -* that reveal properties of floating point arithmetic units. -* Comms. of the ACM, 17, 276-277. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, LIEEE1, LRND - INTEGER LBETA, LT - REAL(DOUBLE) A, B, C, F, ONE, QTR, SAVEC, T1, T2 -* .. -* .. External Functions .. -* .. -* .. Save statement .. - SAVE FIRST, LIEEE1, LBETA, LRND, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ONE = 1 -* -* LBETA, LIEEE1, LT and LRND are the local values of BETA, -* IEEE1, T and RND. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* Compute a = 2.0**m with the smallest positive integer m such -* that -* -* fl( a + 1.0 ) = a. -* - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 10 CONTINUE - IF( C.EQ.ONE ) THEN - A = 2*A - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 10 - END IF -*+ END WHILE -* -* Now compute b = 2.0**m with the smallest positive integer m -* such that -* -* fl( a + b ) .gt. a. -* - B = 1 - C = DLAMC3( A, B ) -* -*+ WHILE( C.EQ.A )LOOP - 20 CONTINUE - IF( C.EQ.A ) THEN - B = 2*B - C = DLAMC3( A, B ) - GO TO 20 - END IF -*+ END WHILE -* -* Now compute the base. a and c are neighbouring floating point -* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so -* their difference is beta. Adding 0.25 to c is to ensure that it -* is truncated to beta and not ( beta - 1 ). -* - QTR = ONE / 4 - SAVEC = C - C = DLAMC3( C, -A ) - LBETA = C + QTR -* -* Now determine whether rounding or chopping occurs, by adding a -* bit less than beta/2 and a bit more than beta/2 to a. -* - B = LBETA - F = DLAMC3( B / 2, -B / 100 ) - C = DLAMC3( F, A ) - IF( C.EQ.A ) THEN - LRND = .TRUE. - ELSE - LRND = .FALSE. - END IF - F = DLAMC3( B / 2, B / 100 ) - C = DLAMC3( F, A ) - IF( ( LRND ) .AND. ( C.EQ.A ) ) - $ LRND = .FALSE. -* -* Try and decide whether rounding is done in the IEEE 'round to -* nearest' style. B/2 is half a unit in the last place of the two -* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit -* zero, and SAVEC is odd. Thus adding B/2 to A should not change -* A, but adding B/2 to SAVEC should change SAVEC. -* - T1 = DLAMC3( B / 2, A ) - T2 = DLAMC3( B / 2, SAVEC ) - LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND -* -* Now find the mantissa, t. It should be the integer part of -* log to the base beta of a, however it is safer to determine t -* by powering. So we find t as the smallest positive integer for -* which -* -* fl( beta**t + 1.0 ) = 1.0. -* - LT = 0 - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 30 CONTINUE - IF( C.EQ.ONE ) THEN - LT = LT + 1 - A = A*LBETA - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 30 - END IF -*+ END WHILE -* - END IF -* - BETA = LBETA - T = LT - RND = LRND - IEEE1 = LIEEE1 - RETURN -* -* End of DLAMC1 -* - END SUBROUTINE DLAMC1 -* -! ################################################################################################################################## -! 033 LAPACK_BLAS_AUX -* - SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) - -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL RND - INTEGER BETA, EMAX, EMIN, T - REAL(DOUBLE) EPS, RMAX, RMIN -* .. -* -* Purpose -* ======= -* -* DLAMC2 determines the machine parameters specified in its argument -* list. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* EPS (output) REAL(DOUBLE) -* The smallest positive number such that -* -* fl( 1.0 - EPS ) .LT. 1.0, -* -* where fl denotes the computed value. -* -* EMIN (output) INTEGER -* The minimum exponent before (gradual) underflow occurs. -* -* RMIN (output) REAL(DOUBLE) -* The smallest normalized number for the machine, given by -* BASE**( EMIN - 1 ), where BASE is the floating point value -* of BETA. -* -* EMAX (output) INTEGER -* The maximum exponent before overflow occurs. -* -* RMAX (output) REAL(DOUBLE) -* The largest positive number for the machine, given by -* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point -* value of BETA. -* -* Further Details -* =============== -* -* The computation of EPS is based on a routine PARANOIA by -* W. Kahan of the University of California at Berkeley. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND - INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, - $ NGNMIN, NGPMIN - REAL(DOUBLE) A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, - $ SIXTH, SMALL, THIRD, TWO, ZERO -* .. -* .. External Functions .. -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Save statement .. - SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, - $ LRMIN, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / , IWARN / .FALSE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ZERO = 0 - ONE = 1 - TWO = 2 -* -* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of -* BETA, T, RND, EPS, EMIN and RMIN. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. -* - CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) -* -* Start to find EPS. -* - B = LBETA - A = B**( -LT ) - LEPS = A -* -* Try some tricks to see whether or not this is the correct EPS. -* - B = TWO / 3 - HALF = ONE / 2 - SIXTH = DLAMC3( B, -HALF ) - THIRD = DLAMC3( SIXTH, SIXTH ) - B = DLAMC3( THIRD, -HALF ) - B = DLAMC3( B, SIXTH ) - B = ABS( B ) - IF( B.LT.LEPS ) - $ B = LEPS -* - LEPS = 1 -* -*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP - 10 CONTINUE - IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN - LEPS = B - C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) - C = DLAMC3( HALF, -C ) - B = DLAMC3( HALF, C ) - C = DLAMC3( HALF, -B ) - B = DLAMC3( HALF, C ) - GO TO 10 - END IF -*+ END WHILE -* - IF( A.LT.LEPS ) - $ LEPS = A -* -* Computation of EPS complete. -* -* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). -* Keep dividing A by BETA until (gradual) underflow occurs. This -* is detected when we cannot recover the previous A. -* - RBASE = ONE / LBETA - SMALL = ONE - DO 20 I = 1, 3 - SMALL = DLAMC3( SMALL*RBASE, ZERO ) - 20 CONTINUE - A = DLAMC3( ONE, SMALL ) - CALL DLAMC4( NGPMIN, ONE, LBETA ) - CALL DLAMC4( NGNMIN, -ONE, LBETA ) - CALL DLAMC4( GPMIN, A, LBETA ) - CALL DLAMC4( GNMIN, -A, LBETA ) - IEEE = .FALSE. -* - IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN - IF( NGPMIN.EQ.GPMIN ) THEN - LEMIN = NGPMIN -* ( Non twos-complement machines, no gradual underflow; -* e.g., VAX ) - ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN - LEMIN = NGPMIN - 1 + LT - IEEE = .TRUE. -* ( Non twos-complement machines, with gradual underflow; -* e.g., IEEE standard followers ) - ELSE - LEMIN = MIN( NGPMIN, GPMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN - IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) -* ( Twos-complement machines, no gradual underflow; -* e.g., CYBER 205 ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. - $ ( GPMIN.EQ.GNMIN ) ) THEN - IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT -* ( Twos-complement machines with gradual underflow; -* no known machine ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE - LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -*** -* Comment out this if block if EMIN is ok - IF( IWARN ) THEN - FIRST = .TRUE. - WRITE( 6, FMT = 9999 )LEMIN - END IF -*** -* -* Assume IEEE arithmetic if we found denormalised numbers above, -* or if arithmetic seems to round in the IEEE style, determined -* in routine DLAMC1. A true IEEE machine should have both things -* true; however, faulty machines may have one or the other. -* - IEEE = IEEE .OR. LIEEE1 -* -* Compute RMIN by successive division by BETA. We could compute -* RMIN as BASE**( EMIN - 1 ), but some machines underflow during -* this computation. -* - LRMIN = 1 - DO 30 I = 1, 1 - LEMIN - LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) - 30 CONTINUE -* -* Finally, call DLAMC5 to compute EMAX and RMAX. -* - CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) - END IF -* - BETA = LBETA - T = LT - RND = LRND - EPS = LEPS - EMIN = LEMIN - RMIN = LRMIN - EMAX = LEMAX - RMAX = LRMAX -* - RETURN -* - 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', - $ ' EMIN = ', I8, / - $ ' If, after inspection, the value EMIN looks', - $ ' acceptable please comment out ', - $ / ' the IF block as marked within the code of routine', - $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) -* -* End of DLAMC2 -* - END SUBROUTINE DLAMC2 -* -! ################################################################################################################################## -! 034 LAPACK_BLAS_AUX -* - DOUBLE PRECISION FUNCTION DLAMC3( A, B ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - REAL(DOUBLE) A, B -* .. -* -* Purpose -* ======= -* -* DLAMC3 is intended to force A and B to be stored prior to doing -* the addition of A and B , for use in situations where optimizers -* might hold one of these in a register. -* -* Arguments -* ========= -* -* A, B (input) REAL(DOUBLE) -* The values A and B. -* -* ===================================================================== -* -* .. Executable Statements .. -* - DLAMC3 = A + B -* - RETURN -* -* End of DLAMC3 -* - END FUNCTION DLAMC3 -* -! ################################################################################################################################## -! 035 LAPACK_BLAS_AUX -* - SUBROUTINE DLAMC4( EMIN, START, BASE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER BASE, EMIN - REAL(DOUBLE) START -* .. -* -* Purpose -* ======= -* -* DLAMC4 is a service routine for DLAMC2. -* -* Arguments -* ========= -* -* EMIN (output) EMIN -* The minimum exponent before (gradual) underflow, computed by -* setting A = START and dividing by BASE until the previous A -* can not be recovered. -* -* START (input) REAL(DOUBLE) -* The starting point for determining EMIN. -* -* BASE (input) INTEGER -* The base of the machine. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I - REAL(DOUBLE) A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO -* .. -* .. External Functions .. -* .. -* .. Executable Statements .. -* - A = START - ONE = 1 - RBASE = ONE / BASE - ZERO = 0 - EMIN = 1 - B1 = DLAMC3( A*RBASE, ZERO ) - C1 = A - C2 = A - D1 = A - D2 = A -*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. -* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP - 10 CONTINUE - IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. - $ ( D2.EQ.A ) ) THEN - EMIN = EMIN - 1 - A = B1 - B1 = DLAMC3( A / BASE, ZERO ) - C1 = DLAMC3( B1*BASE, ZERO ) - D1 = ZERO - DO 20 I = 1, BASE - D1 = D1 + B1 - 20 CONTINUE - B2 = DLAMC3( A*RBASE, ZERO ) - C2 = DLAMC3( B2 / RBASE, ZERO ) - D2 = ZERO - DO 30 I = 1, BASE - D2 = D2 + B2 - 30 CONTINUE - GO TO 10 - END IF -*+ END WHILE -* - RETURN -* -* End of DLAMC4 -* - END SUBROUTINE DLAMC4 -* -! ################################################################################################################################## -! 036 LAPACK_BLAS_AUX -* - SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER BETA, EMAX, EMIN, P - REAL(DOUBLE) RMAX -* .. -* -* Purpose -* ======= -* -* DLAMC5 attempts to compute RMAX, the largest machine floating-point -* number, without overflow. It assumes that EMAX + abs(EMIN) sum -* approximately to a power of 2. It will fail on machines where this -* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, -* EMAX = 28718). It will also fail if the value supplied for EMIN is -* too large (i.e. too close to zero), probably with overflow. -* -* Arguments -* ========= -* -* BETA (input) INTEGER -* The base of floating-point arithmetic. -* -* P (input) INTEGER -* The number of base BETA digits in the mantissa of a -* floating-point value. -* -* EMIN (input) INTEGER -* The minimum exponent before (gradual) underflow. -* -* IEEE (input) LOGICAL -* A logical flag specifying whether or not the arithmetic -* system is thought to comply with the IEEE standard. -* -* EMAX (output) INTEGER -* The largest exponent before overflow -* -* RMAX (output) REAL(DOUBLE) -* The largest machine floating-point number. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP - REAL(DOUBLE) OLDY, RECBAS, Y, Z -* .. -* .. External Functions .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* First compute LEXP and UEXP, two powers of 2 that bound -* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum -* approximately to the bound that is closest to abs(EMIN). -* (EMAX is the exponent of the required number RMAX). -* - LEXP = 1 - EXBITS = 1 - 10 CONTINUE - TRY = LEXP*2 - IF( TRY.LE.( -EMIN ) ) THEN - LEXP = TRY - EXBITS = EXBITS + 1 - GO TO 10 - END IF - IF( LEXP.EQ.-EMIN ) THEN - UEXP = LEXP - ELSE - UEXP = TRY - EXBITS = EXBITS + 1 - END IF -* -* Now -LEXP is less than or equal to EMIN, and -UEXP is greater -* than or equal to EMIN. EXBITS is the number of bits needed to -* store the exponent. -* - IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN - EXPSUM = 2*LEXP - ELSE - EXPSUM = 2*UEXP - END IF -* -* EXPSUM is the exponent range, approximately equal to -* EMAX - EMIN + 1 . -* - EMAX = EXPSUM + EMIN - 1 - NBITS = 1 + EXBITS + P -* -* NBITS is the total number of bits needed to store a -* floating-point number. -* - IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN -* -* Either there are an odd number of bits used to store a -* floating-point number, which is unlikely, or some bits are -* not used in the representation of numbers, which is possible, -* (e.g. Cray machines) or the mantissa has an implicit bit, -* (e.g. IEEE machines, Dec Vax machines), which is perhaps the -* most likely. We have to assume the last alternative. -* If this is true, then we need to reduce EMAX by one because -* there must be some way of representing zero in an implicit-bit -* system. On machines like Cray, we are reducing EMAX by one -* unnecessarily. -* - EMAX = EMAX - 1 - END IF -* - IF( IEEE ) THEN -* -* Assume we are on an IEEE machine which reserves one exponent -* for infinity and NaN. -* - EMAX = EMAX - 1 - END IF -* -* Now create RMAX, the largest machine number, which should -* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . -* -* First compute 1.0 - BETA**(-P), being careful that the -* result is less than 1.0 . -* - RECBAS = ONE / BETA - Z = BETA - ONE - Y = ZERO - DO 20 I = 1, P - Z = Z*RECBAS - IF( Y.LT.ONE ) - $ OLDY = Y - Y = DLAMC3( Y, Z ) - 20 CONTINUE - IF( Y.GE.ONE ) - $ Y = OLDY -* -* Now multiply by BETA**EMAX to get RMAX. -* - DO 30 I = 1, EMAX - Y = DLAMC3( Y*BETA, ZERO ) - 30 CONTINUE -* - RMAX = Y - RETURN -* -* End of DLAMC5 -* - END SUBROUTINE DLAMC5 - -! ################################################################################################################################## -! 037 LAPACK_BLAS_AUX - - DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, - $ WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER K, LDAB, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLANSB returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of an -* n by n symmetric band matrix A, with k super-diagonals. -* -* Description -* =========== -* -* DLANSB returns the value -* -* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in DLANSB as described -* above. -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* band matrix A is supplied. -* = 'U': Upper triangular part is supplied -* = 'L': Lower triangular part is supplied -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. When N = 0, DLANSB is -* set to zero. -* -* K (input) INTEGER -* The number of super-diagonals or sub-diagonals of the -* band matrix A. K >= 0. -* -* AB (input) REAL(DOUBLE) array, dimension (LDAB,N) -* The upper or lower triangle of the symmetric band matrix A, -* stored in the first K+1 rows of AB. The j-th column of A is -* stored in the j-th column of the array AB as follows: -* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= K+1. -* -* WORK (workspace) REAL(DOUBLE) array, dimension (LWORK), -* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -* WORK is not referenced. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L - REAL(DOUBLE) ABSA, SCALE, SUM, VALUE -* .. -* .. External Subroutines .. -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j, n, cr13_lba - ENDIF - DO 10 I = MAX( K+2-J, 1 ), K + 1 - VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j, n, cr13_lba - ENDIF - DO 30 I = 1, MIN( N+1-J, K+1 ) - VALUE = MAX( VALUE, ABS( AB( I, J ) ) ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is symmetric). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j, n, cr13_lba - ENDIF - SUM = ZERO - L = K + 1 - J - DO 50 I = MAX( 1, J-K ), J - 1 - ABSA = ABS( AB( L+I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 50 CONTINUE - WORK( J ) = SUM + ABS( AB( K+1, J ) ) - 60 CONTINUE - DO 70 I = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') i, n, cr13_lba - ENDIF - VALUE = MAX( VALUE, WORK( I ) ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j, n, cr13_lba - ENDIF - SUM = WORK( J ) + ABS( AB( 1, J ) ) - L = 1 - J - DO 90 I = J + 1, MIN( N, J+K ) - ABSA = ABS( AB( L+I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 90 CONTINUE - VALUE = MAX( VALUE, SUM ) - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( K.GT.0 ) THEN - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j, n, cr13_lba - ENDIF - CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), - $ 1, SCALE, SUM ) - 110 CONTINUE - L = K + 1 - ELSE - DO 120 J = 1, N - 1 - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j, n, cr13_lba - ENDIF - CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, - $ SUM ) - 120 CONTINUE - L = 1 - END IF - SUM = 2*SUM - ELSE - L = 1 - END IF - CALL DLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM ) - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANSB = VALUE - RETURN -* -* End of DLANSB -* -12345 format(5x,'Row ',i8,' of ',i8, a) - - END FUNCTION DLANSB - -! ################################################################################################################################## -! 039 LAPACK_BLAS_AUX - - DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM, UPLO - INTEGER LDA, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLANSY returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* real symmetric matrix A. -* -* Description -* =========== -* -* DLANSY returns the value -* -* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in DLANSY as described -* above. -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is to be referenced. -* = 'U': Upper triangular part of A is referenced -* = 'L': Lower triangular part of A is referenced -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. When N = 0, DLANSY is -* set to zero. -* -* A (input) REAL(DOUBLE) array, dimension (LDA,N) -* The symmetric matrix A. If UPLO = 'U', the leading n by n -* upper triangular part of A contains the upper triangular part -* of the matrix A, and the strictly lower triangular part of A -* is not referenced. If UPLO = 'L', the leading n by n lower -* triangular part of A contains the lower triangular part of -* the matrix A, and the strictly upper triangular part of A is -* not referenced. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(N,1). -* -* WORK (workspace) REAL(DOUBLE) array, dimension (LWORK), -* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, -* WORK is not referenced. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - REAL(DOUBLE) ABSA, SCALE, SUM, VALUE -* .. -* .. External Subroutines .. -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - IF( N.EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = J, N - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. - $ ( NORM.EQ.'1' ) ) THEN -* -* Find normI(A) ( = norm1(A), since A is symmetric). -* - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, J - 1 - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 50 CONTINUE - WORK( J ) = SUM + ABS( A( J, J ) ) - 60 CONTINUE - DO 70 I = 1, N - VALUE = MAX( VALUE, WORK( I ) ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - WORK( I ) = ZERO - 80 CONTINUE - DO 100 J = 1, N - SUM = WORK( J ) + ABS( A( J, J ) ) - DO 90 I = J + 1, N - ABSA = ABS( A( I, J ) ) - SUM = SUM + ABSA - WORK( I ) = WORK( I ) + ABSA - 90 CONTINUE - VALUE = MAX( VALUE, SUM ) - 100 CONTINUE - END IF - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 2, N - CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) - 110 CONTINUE - ELSE - DO 120 J = 1, N - 1 - CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) - 120 CONTINUE - END IF - SUM = 2*SUM - CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANSY = VALUE - RETURN -* -* End of DLANSY -* - END FUNCTION DLANSY - -! ################################################################################################################################## -! 040 LAPACK_BLAS_AUX - - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - REAL(DOUBLE) X, Y -* .. -* -* Purpose -* ======= -* -* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -* overflow. -* -* Arguments -* ========= -* -* X (input) REAL(DOUBLE) -* Y (input) REAL(DOUBLE) -* X and Y specify the values x and y. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D0 ) - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - REAL(DOUBLE) W, XABS, YABS, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - RETURN -* -* End of DLAPY2 -* - END FUNCTION DLAPY2 - -! ################################################################################################################################## -! 041 LAPACK_BLAS_AUX - - SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED - & , thresh, small, large ) ! My line -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER EQUED, UPLO - INTEGER KD, LDAB, N - REAL(DOUBLE) AMAX, SCOND - REAL(DOUBLE) thresh, small, large ! My line -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ), S( * ) -* .. -* -* Purpose -* ======= -* -* DLAQSB equilibrates a symmetric band matrix A using the scaling -* factors in the vector S. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of super-diagonals of the matrix A if UPLO = 'U', -* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB,N) -* On entry, the upper or lower triangle of the symmetric band -* matrix A, stored in the first KD+1 rows of the array. The -* j-th column of A is stored in the j-th column of the array AB -* as follows: -* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -* -* On exit, if INFO = 0, the triangular factor U or L from the -* Cholesky factorization A = U'*U or A = L*L' of the band -* matrix A, in the same storage format as A. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* The scale factors for A. -------------------- -* -* SCOND (input) REAL(DOUBLE) -* Ratio of the smallest S(i) to the largest S(i). -* -* AMAX (input) REAL(DOUBLE) -* Absolute value of largest matrix entry. -* -* EQUED (output) CHARACTER*1 -* Specifies whether or not equilibration was done. -* = 'N': No equilibration. -* = 'Y': Equilibration was done, i.e., A has been replaced by -* diag(S) * A * diag(S). - -! thresh (input) REAL(DOUBLE) -! threshold value (see comment below) ! My line - -! small (output) REAL(DOUBLE) -! threshold value (see comment below) ! My line - -! large (output) REAL(DOUBLE) -! threshold value (see comment below) ! My line -* -* Internal Parameters -* =================== -* -* THRESH is a threshold value used to decide if scaling should be done -* based on the ratio of the scaling factors. If SCOND < THRESH, -* scaling is done. -* -* LARGE and SMALL are threshold values used to decide if scaling should -* be done based on the absolute size of the largest matrix element. -* If AMAX > LARGE or AMAX < SMALL, scaling is done. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - REAL(DOUBLE) CJ -* .. -* .. External Functions .. - LOGICAL LSAME - REAL(DOUBLE) DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - EQUED = 'N' - RETURN - END IF -* -* Initialize LARGE and SMALL. -* - SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - LARGE = ONE / SMALL -* - IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN -* -* No equilibration -* - EQUED = 'N' - ELSE -* -* Replace A by diag(S) * A * diag(S). -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Upper triangle of A is stored in band format. -* - DO 20 J = 1, N - CJ = S( J ) - DO 10 I = MAX( 1, J-KD ), J - AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J ) - 10 CONTINUE - 20 CONTINUE - ELSE -* -* Lower triangle of A is stored. -* - DO 40 J = 1, N - CJ = S( J ) - DO 30 I = J, MIN( N, J+KD ) - AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J ) - 30 CONTINUE - 40 CONTINUE - END IF - EQUED = 'Y' - END IF -* - RETURN -* -* End of DLAQSB -* - END SUBROUTINE DLAQSB - -! ################################################################################################################################## -! 042 LAPACK_BLAS_AUX - - SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INCC, INCX, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) C( * ), S( * ), X( * ), Y( * ), Z( * ) -* .. -* -* Purpose -* ======= -* -* DLAR2V applies a vector of real plane rotations from both sides to -* a sequence of 2-by-2 real symmetric matrices, defined by the elements -* of the vectors x, y and z. For i = 1,2,...,n -* -* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) -* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of plane rotations to be applied. -* -* X (input/output) REAL(DOUBLE) array, -* dimension (1+(N-1)*INCX) -* The vector x. -* -* Y (input/output) REAL(DOUBLE) array, -* dimension (1+(N-1)*INCX) -* The vector y. -* -* Z (input/output) REAL(DOUBLE) array, -* dimension (1+(N-1)*INCX) -* The vector z. -* -* INCX (input) INTEGER -* The increment between elements of X, Y and Z. INCX > 0. -* -* C (input) REAL(DOUBLE) array, dimension (1+(N-1)*INCC) -* The cosines of the plane rotations. -* -* S (input) REAL(DOUBLE) array, dimension (1+(N-1)*INCC) -* The sines of the plane rotations. -* -* INCC (input) INTEGER -* The increment between elements of C and S. INCC > 0. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IX - REAL(DOUBLE) CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI -* .. -* .. Executable Statements .. -* - IX = 1 - IC = 1 - DO 10 I = 1, N - XI = X( IX ) - YI = Y( IX ) - ZI = Z( IX ) - CI = C( IC ) - SI = S( IC ) - T1 = SI*ZI - T2 = CI*ZI - T3 = T2 - SI*XI - T4 = T2 + SI*YI - T5 = CI*XI + T1 - T6 = CI*YI - T1 - X( IX ) = CI*T5 + SI*T4 - Y( IX ) = CI*T6 - SI*T3 - Z( IX ) = CI*T4 - SI*T5 - IX = IX + INCX - IC = IC + INCC - 10 CONTINUE -* -* End of DLAR2V -* - RETURN - - END SUBROUTINE DLAR2V - -! ################################################################################################################################## -! 043 LAPACK_BLAS_AUX - - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - REAL(DOUBLE) TAU -* .. -* .. Array Arguments .. - REAL(DOUBLE) C( LDC, * ), V( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLARF applies a real elementary reflector H to a real m by n matrix -* C, from either the left or the right. H is represented in the form -* -* H = I - tau * v * v' -* -* where tau is a real scalar and v is a real vector. -* -* If tau = 0, then H is taken to be the unit matrix. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': form H * C -* = 'R': form C * H -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* V (input) REAL(DOUBLE) array, dimension -* (1 + (M-1)*abs(INCV)) if SIDE = 'L' -* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -* The vector v in the representation of H. V is not used if -* TAU = 0. -* -* INCV (input) INTEGER -* The increment between elements of v. INCV <> 0. -* -* TAU (input) REAL(DOUBLE) -* The value tau in the representation of H. -* -* C (input/output) REAL(DOUBLE) array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by the matrix H * C if SIDE = 'L', -* or C * H if SIDE = 'R'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) REAL(DOUBLE) array, dimension -* (N) if SIDE = 'L' -* or (M) if SIDE = 'R' -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. External Subroutines .. -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C -* - IF( TAU.NE.ZERO ) THEN -* -* w := C' * v -* - CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, - $ WORK, 1 ) -* -* C := C - v * w' -* - CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( TAU.NE.ZERO ) THEN -* -* w := C * v -* - CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C := C - w * v' -* - CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END SUBROUTINE DLARF - -! ################################################################################################################################## -! 044 LAPACK_BLAS_AUX - - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. -! B 02/07/04 //////////////////////////////////////////////////////////B - REAL(DOUBLE) C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -! Double the first dimension - -! REAL(DOUBLE) C( LDC, * ), T( LDT, * ), V( LDV, * ), -! $ WORK( 2*LDWORK, * ) -! E ////////////////////////////////////////////////////////////////////E -* .. -* -* Purpose -* ======= -* -* DLARFB applies a real block reflector H or its transpose H' to a -* real m by n matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H' from the Left -* = 'R': apply H or H' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'T': apply H' (Transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) REAL(DOUBLE) array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) REAL(DOUBLE) array, dimension (LDT,K) -* The triangular k by k matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) REAL(DOUBLE) array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDA >= max(1,M). -* -* WORK (workspace) REAL(DOUBLE) array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C1' -* - DO 10 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W' -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2' -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C2' -* - DO 70 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W' -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 90 J = 1, K - DO 80 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1' -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C1' -* - DO 130 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2' -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, - $ WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2' * W' -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2' -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C2' -* - DO 190 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1' -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1' * W' -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 210 J = 1, K - DO 200 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1' -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END SUBROUTINE DLARFB - -! ################################################################################################################################## -! 045 LAPACK_BLAS_AUX - - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INCX, N - REAL(DOUBLE) ALPHA, TAU -* .. -* .. Array Arguments .. - REAL(DOUBLE) X( * ) -* .. -* -* Purpose -* ======= -* -* DLARFG generates a real elementary reflector H of order n, such -* that -* -* H * ( alpha ) = ( beta ), H' * H = I. -* ( x ) ( 0 ) -* -* where alpha and beta are scalars, and x is an (n-1)-element real -* vector. H is represented in the form -* -* H = I - tau * ( 1 ) * ( 1 v' ) , -* ( v ) -* -* where tau is a real scalar and v is a real (n-1)-element -* vector. -* -* If the elements of x are all zero, then tau = 0 and H is taken to be -* the unit matrix. -* -* Otherwise 1 <= tau <= 2. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the elementary reflector. -* -* ALPHA (input/output) REAL(DOUBLE) -* On entry, the value alpha. -* On exit, it is overwritten with the value beta. -* -* X (input/output) REAL(DOUBLE) array, dimension -* (1+(N-2)*abs(INCX)) -* On entry, the vector x. -* On exit, it is overwritten with the vector v. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* TAU (output) REAL(DOUBLE) -* The value tau. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - REAL(DOUBLE) BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - KNT = 0 - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - ALPHA = BETA - DO 20 J = 1, KNT - ALPHA = ALPHA*SAFMIN - 20 CONTINUE - ELSE - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) - ALPHA = BETA - END IF - END IF -* - RETURN -* -* End of DLARFG -* - END SUBROUTINE DLARFG - -! ################################################################################################################################## -! 046 LAPACK_BLAS_AUX - - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* DLARFT forms the triangular factor T of a real block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V' -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V' * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) REAL(DOUBLE) array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) REAL(DOUBLE) array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) REAL(DOUBLE) array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - REAL(DOUBLE) VII -* .. -* .. External Subroutines .. -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 I = 1, K - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -* -* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) -* - CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, - $ T( 1, I ), 1 ) - ELSE -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' -* - CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - END IF - 20 CONTINUE - ELSE - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, - $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' -* - CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, - $ T( I+1, I ), 1 ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of DLARFT -* - END SUBROUTINE DLARFT - -! ################################################################################################################################## -! 047 LAPACK_BLAS_AUX - - SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCC, INCX, INCY, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) C( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DLARGV generates a vector of real plane rotations, determined by -* elements of the real vectors x and y. For i = 1,2,...,n -* -* ( c(i) s(i) ) ( x(i) ) = ( a(i) ) -* ( -s(i) c(i) ) ( y(i) ) = ( 0 ) -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of plane rotations to be generated. -* -* X (input/output) REAL(DOUBLE) array, -* dimension (1+(N-1)*INCX) -* On entry, the vector x. -* On exit, x(i) is overwritten by a(i), for i = 1,...,n. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* Y (input/output) REAL(DOUBLE) array, -* dimension (1+(N-1)*INCY) -* On entry, the vector y. -* On exit, the sines of the plane rotations. -* -* INCY (input) INTEGER -* The increment between elements of Y. INCY > 0. -* -* C (output) REAL(DOUBLE) array, dimension (1+(N-1)*INCC) -* The cosines of the plane rotations. -* -* INCC (input) INTEGER -* The increment between elements of C. INCC > 0. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IC, IX, IY - REAL(DOUBLE) F, G, T, TT -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. -* - IX = 1 - IY = 1 - IC = 1 - DO 10 I = 1, N - F = X( IX ) - G = Y( IY ) - IF( G.EQ.ZERO ) THEN - C( IC ) = ONE - ELSE IF( F.EQ.ZERO ) THEN - C( IC ) = ZERO - Y( IY ) = ONE - X( IX ) = G - ELSE IF( ABS( F ).GT.ABS( G ) ) THEN - T = G / F - TT = SQRT( ONE+T*T ) - C( IC ) = ONE / TT - Y( IY ) = T*C( IC ) - X( IX ) = F*TT - ELSE - T = F / G - TT = SQRT( ONE+T*T ) - Y( IY ) = ONE / TT - C( IC ) = T*Y( IY ) - X( IX ) = G*TT - END IF - IC = IC + INCC - IY = IY + INCY - IX = IX + INCX - 10 CONTINUE - RETURN -* -* End of DLARGV -* - END SUBROUTINE DLARGV - -! ################################################################################################################################## -! 048 LAPACK_BLAS_AUX - - SUBROUTINE DLARNV( IDIST, ISEED, N, X ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER IDIST, N -* .. -* .. Array Arguments .. - INTEGER ISEED( 4 ) - REAL(DOUBLE) X( * ) -* .. -* -* Purpose -* ======= -* -* DLARNV returns a vector of n random real numbers from a uniform or -* normal distribution. -* -* Arguments -* ========= -* -* IDIST (input) INTEGER -* Specifies the distribution of the random numbers: -* = 1: uniform (0,1) -* = 2: uniform (-1,1) -* = 3: normal (0,1) -* -* ISEED (input/output) INTEGER array, dimension (4) -* On entry, the seed of the random number generator; the array -* elements must be between 0 and 4095, and ISEED(4) must be -* odd. -* On exit, the seed is updated. -* -* N (input) INTEGER -* The number of random numbers to be generated. -* -* X (output) REAL(DOUBLE) array, dimension (N) -* The generated random numbers. -* -* Further Details -* =============== -* -* This routine calls the auxiliary routine DLARUV to generate random -* real numbers from a uniform (0,1) distribution, in batches of up to -* 128 using vectorisable code. The Box-Muller method is used to -* transform numbers from a uniform to a normal distribution. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, TWO - PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) - INTEGER LV - PARAMETER ( LV = 128 ) - REAL(DOUBLE) TWOPI - PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IL, IL2, IV -* .. -* .. Local Arrays .. - REAL(DOUBLE) U( LV ) -* .. -* .. Intrinsic Functions .. - INTRINSIC COS, LOG, MIN, SQRT -* .. -* .. External Subroutines .. -* .. -* .. Executable Statements .. -* - DO 40 IV = 1, N, LV / 2 - IL = MIN( LV / 2, N-IV+1 ) - IF( IDIST.EQ.3 ) THEN - IL2 = 2*IL - ELSE - IL2 = IL - END IF -* -* Call DLARUV to generate IL2 numbers from a uniform (0,1) -* distribution (IL2 <= LV) -* - CALL DLARUV( ISEED, IL2, U ) -* - IF( IDIST.EQ.1 ) THEN -* -* Copy generated numbers -* - DO 10 I = 1, IL - X( IV+I-1 ) = U( I ) - 10 CONTINUE - ELSE IF( IDIST.EQ.2 ) THEN -* -* Convert generated numbers to uniform (-1,1) distribution -* - DO 20 I = 1, IL - X( IV+I-1 ) = TWO*U( I ) - ONE - 20 CONTINUE - ELSE IF( IDIST.EQ.3 ) THEN -* -* Convert generated numbers to normal (0,1) distribution -* - DO 30 I = 1, IL - X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* - $ COS( TWOPI*U( 2*I ) ) - 30 CONTINUE - END IF - 40 CONTINUE - RETURN -* -* End of DLARNV -* - END SUBROUTINE DLARNV - -! ################################################################################################################################## -! 049 LAPACK_BLAS_AUX - - SUBROUTINE DLARTG( F, G, CS, SN, R ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - REAL(DOUBLE) CS, F, G, R, SN -* .. -* -* Purpose -* ======= -* -* DLARTG generate a plane rotation so that -* -* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. -* [ -SN CS ] [ G ] [ 0 ] -* -* This is a slower, more accurate version of the BLAS1 routine DROTG, -* with the following other differences: -* F and G are unchanged on return. -* If G=0, then CS=1 and SN=0. -* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any -* floating point operations (saves work in DBDSQR when -* there are zeros on the diagonal). -* -* If F exceeds G in magnitude, CS will be positive. -* -* Arguments -* ========= -* -* F (input) REAL(DOUBLE) -* The first component of vector to be rotated. -* -* G (input) REAL(DOUBLE) -* The second component of vector to be rotated. -* -* CS (output) REAL(DOUBLE) -* The cosine of the rotation. -* -* SN (output) REAL(DOUBLE) -* The sine of the rotation. -* -* R (output) REAL(DOUBLE) -* The nonzero component of the rotated vector. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D0 ) - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D0 ) - REAL(DOUBLE) TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST - INTEGER COUNT, I - REAL(DOUBLE) EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE -* .. -* .. External Functions .. - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, SQRT -* .. -* .. Save statement .. - SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'E' ) - SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( DLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 - END IF - IF( G.EQ.ZERO ) THEN - CS = ONE - SN = ZERO - R = F - ELSE IF( F.EQ.ZERO ) THEN - CS = ZERO - SN = ONE - R = G - ELSE - F1 = F - G1 = G - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) THEN - COUNT = 0 - 10 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMN2 - G1 = G1*SAFMN2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) - $ GO TO 10 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 20 I = 1, COUNT - R = R*SAFMX2 - 20 CONTINUE - ELSE IF( SCALE.LE.SAFMN2 ) THEN - COUNT = 0 - 30 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMX2 - G1 = G1*SAFMX2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.LE.SAFMN2 ) - $ GO TO 30 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 40 I = 1, COUNT - R = R*SAFMN2 - 40 CONTINUE - ELSE - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - END IF - IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN - CS = -CS - SN = -SN - R = -R - END IF - END IF - RETURN -* -* End of DLARTG -* - END SUBROUTINE DLARTG - -! ################################################################################################################################## -! 050 LAPACK_BLAS_AUX - - SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INCC, INCX, INCY, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) C( * ), S( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DLARTV applies a vector of real plane rotations to elements of the -* real vectors x and y. For i = 1,2,...,n -* -* ( x(i) ) := ( c(i) s(i) ) ( x(i) ) -* ( y(i) ) ( -s(i) c(i) ) ( y(i) ) -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of plane rotations to be applied. -* -* X (input/output) REAL(DOUBLE) array, -* dimension (1+(N-1)*INCX) -* The vector x. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* Y (input/output) REAL(DOUBLE) array, -* dimension (1+(N-1)*INCY) -* The vector y. -* -* INCY (input) INTEGER -* The increment between elements of Y. INCY > 0. -* -* C (input) REAL(DOUBLE) array, dimension (1+(N-1)*INCC) -* The cosines of the plane rotations. -* -* S (input) REAL(DOUBLE) array, dimension (1+(N-1)*INCC) -* The sines of the plane rotations. -* -* INCC (input) INTEGER -* The increment between elements of C and S. INCC > 0. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IC, IX, IY - REAL(DOUBLE) XI, YI -* .. -* .. Executable Statements .. -* - IX = 1 - IY = 1 - IC = 1 - DO 10 I = 1, N - XI = X( IX ) - YI = Y( IY ) - X( IX ) = C( IC )*XI + S( IC )*YI - Y( IY ) = C( IC )*YI - S( IC )*XI - IX = IX + INCX - IY = IY + INCY - IC = IC + INCC - 10 CONTINUE - RETURN -* -* End of DLARTV -* - END SUBROUTINE DLARTV - -! ################################################################################################################################## -! 051 LAPACK_BLAS_AUX - - SUBROUTINE DLARUV( ISEED, N, X ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER N -* .. -* .. Array Arguments .. - INTEGER ISEED( 4 ) - REAL(DOUBLE) X( N ) -* .. -* -* Purpose -* ======= -* -* DLARUV returns a vector of n random real numbers from a uniform (0,1) -* distribution (n <= 128). -* -* This is an auxiliary routine called by DLARNV and ZLARNV. -* -* Arguments -* ========= -* -* ISEED (input/output) INTEGER array, dimension (4) -* On entry, the seed of the random number generator; the array -* elements must be between 0 and 4095, and ISEED(4) must be -* odd. -* On exit, the seed is updated. -* -* N (input) INTEGER -* The number of random numbers to be generated. N <= 128. -* -* X (output) REAL(DOUBLE) array, dimension (N) -* The generated random numbers. -* -* Further Details -* =============== -* -* This routine uses a multiplicative congruential method with modulus -* 2**48 and multiplier 33952834046453 (see G.S.Fishman, -* 'Multiplicative congruential random number generators with modulus -* 2**b: an exhaustive analysis for b = 32 and a partial analysis for -* b = 48', Math. Comp. 189, pp 331-344, 1990). -* -* 48-bit integers are stored in 4 integer array elements with 12 bits -* per element. Hence the routine is portable across machines with -* integers of 32 bits or more. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D0 ) - INTEGER LV, IPW2 - REAL(DOUBLE) R - PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) -* .. -* .. Local Scalars .. - INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J -* .. -* .. Local Arrays .. - INTEGER MM( LV, 4 ) -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MIN, MOD -* .. -* .. Data statements .. - DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, - $ 2549 / - DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, - $ 1145 / - DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, - $ 2253 / - DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, - $ 305 / - DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, - $ 3301 / - DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, - $ 1065 / - DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, - $ 3133 / - DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, - $ 2913 / - DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, - $ 3285 / - DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, - $ 1241 / - DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, - $ 1197 / - DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, - $ 3729 / - DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, - $ 2501 / - DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, - $ 1673 / - DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, - $ 541 / - DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, - $ 2753 / - DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, - $ 949 / - DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, - $ 2361 / - DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, - $ 1165 / - DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, - $ 4081 / - DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, - $ 2725 / - DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, - $ 3305 / - DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, - $ 3069 / - DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, - $ 3617 / - DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, - $ 3733 / - DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, - $ 409 / - DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, - $ 2157 / - DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, - $ 1361 / - DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, - $ 3973 / - DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, - $ 1865 / - DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, - $ 2525 / - DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, - $ 1409 / - DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, - $ 3445 / - DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, - $ 3577 / - DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, - $ 77 / - DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, - $ 3761 / - DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, - $ 2149 / - DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, - $ 1449 / - DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, - $ 3005 / - DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, - $ 225 / - DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, - $ 85 / - DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, - $ 3673 / - DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, - $ 3117 / - DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, - $ 3089 / - DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, - $ 1349 / - DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, - $ 2057 / - DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, - $ 413 / - DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, - $ 65 / - DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, - $ 1845 / - DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, - $ 697 / - DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, - $ 3085 / - DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, - $ 3441 / - DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, - $ 1573 / - DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, - $ 3689 / - DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, - $ 2941 / - DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, - $ 929 / - DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, - $ 533 / - DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, - $ 2841 / - DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, - $ 4077 / - DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, - $ 721 / - DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, - $ 2821 / - DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, - $ 2249 / - DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, - $ 2397 / - DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, - $ 2817 / - DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, - $ 245 / - DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, - $ 1913 / - DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, - $ 1997 / - DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, - $ 3121 / - DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, - $ 997 / - DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, - $ 1833 / - DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, - $ 2877 / - DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, - $ 1633 / - DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, - $ 981 / - DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, - $ 2009 / - DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, - $ 941 / - DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, - $ 2449 / - DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, - $ 197 / - DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, - $ 2441 / - DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, - $ 285 / - DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, - $ 1473 / - DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, - $ 2741 / - DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, - $ 3129 / - DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, - $ 909 / - DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, - $ 2801 / - DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, - $ 421 / - DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, - $ 4073 / - DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, - $ 2813 / - DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, - $ 2337 / - DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, - $ 1429 / - DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, - $ 1177 / - DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, - $ 1901 / - DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, - $ 81 / - DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, - $ 1669 / - DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, - $ 2633 / - DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, - $ 2269 / - DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, - $ 129 / - DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, - $ 1141 / - DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, - $ 249 / - DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, - $ 3917 / - DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, - $ 2481 / - DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, - $ 3941 / - DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, - $ 2217 / - DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, - $ 2749 / - DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, - $ 3041 / - DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, - $ 1877 / - DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, - $ 345 / - DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, - $ 2861 / - DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, - $ 1809 / - DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, - $ 3141 / - DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, - $ 2825 / - DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, - $ 157 / - DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, - $ 2881 / - DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, - $ 3637 / - DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, - $ 1465 / - DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, - $ 2829 / - DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, - $ 2161 / - DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, - $ 3365 / - DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, - $ 361 / - DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, - $ 2685 / - DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, - $ 3745 / - DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, - $ 2325 / - DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, - $ 3609 / - DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, - $ 3821 / - DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, - $ 3537 / - DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, - $ 517 / - DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, - $ 3017 / - DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, - $ 2141 / - DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, - $ 1537 / -* .. -* .. Executable Statements .. -* - I1 = ISEED( 1 ) - I2 = ISEED( 2 ) - I3 = ISEED( 3 ) - I4 = ISEED( 4 ) -* - DO 10 I = 1, MIN( N, LV ) -* -* Multiply the seed by i-th power of the multiplier modulo 2**48 -* - IT4 = I4*MM( I, 4 ) - IT3 = IT4 / IPW2 - IT4 = IT4 - IPW2*IT3 - IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) - IT2 = IT3 / IPW2 - IT3 = IT3 - IPW2*IT2 - IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) - IT1 = IT2 / IPW2 - IT2 = IT2 - IPW2*IT1 - IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + - $ I4*MM( I, 1 ) - IT1 = MOD( IT1, IPW2 ) -* -* Convert 48-bit integer to a real number in the interval (0,1) -* - X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* - $ DBLE( IT4 ) ) ) ) - 10 CONTINUE -* -* Return final value of seed -* - ISEED( 1 ) = IT1 - ISEED( 2 ) = IT2 - ISEED( 3 ) = IT3 - ISEED( 4 ) = IT4 - RETURN -* -* End of DLARUV -* - END SUBROUTINE DLARUV - -! ################################################################################################################################## -! 052 LAPACK_BLAS_AUX - - SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N - REAL(DOUBLE) CFROM, CTO -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASCL multiplies the M by N real matrix A by the real scalar -* CTO/CFROM. This is done without over/underflow as long as the final -* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -* A may be full, upper triangular, lower triangular, upper Hessenberg, -* or banded. -* -* Arguments -* ========= -* -* TYPE (input) CHARACTER*1 -* TYPE indices the storage type of the input matrix. -* = 'G': A is a full matrix. -* = 'L': A is a lower triangular matrix. -* = 'U': A is an upper triangular matrix. -* = 'H': A is an upper Hessenberg matrix. -* = 'B': A is a symmetric band matrix with lower bandwidth KL -* and upper bandwidth KU and with the only the lower -* half stored. -* = 'Q': A is a symmetric band matrix with lower bandwidth KL -* and upper bandwidth KU and with the only the upper -* half stored. -* = 'Z': A is a band matrix with lower bandwidth KL and upper -* bandwidth KU. -* -* KL (input) INTEGER -* The lower bandwidth of A. Referenced only if TYPE = 'B', -* 'Q' or 'Z'. -* -* KU (input) INTEGER -* The upper bandwidth of A. Referenced only if TYPE = 'B', -* 'Q' or 'Z'. -* -* CFROM (input) REAL(DOUBLE) -* CTO (input) REAL(DOUBLE) -* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed -* without over/underflow if the final result CTO*A(I,J)/CFROM -* can be represented without over/underflow. CFROM must be -* nonzero. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,M) -* The matrix to be multiplied by CTO/CFROM. See TYPE for the -* storage type. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* INFO (output) INTEGER -* 0 - successful exit -* <0 - if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - INTEGER I, ITYPE, J, K1, K2, K3, K4 - REAL(DOUBLE) BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Subroutines .. -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 -* - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -* - IF( ITYPE.EQ.-1 ) THEN - INFO = -1 - ELSE IF( CFROM.EQ.ZERO ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. - $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN - INFO = -7 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -2 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -3 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -9 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASCL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* - CFROMC = CFROM - CTOC = CTO -* - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - CTO1 = CTOC / BIGNUM - IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - END IF -* - IF( ITYPE.EQ.0 ) THEN -* -* Full matrix -* - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( ITYPE.EQ.1 ) THEN -* -* Lower triangular matrix -* - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -* - ELSE IF( ITYPE.EQ.2 ) THEN -* -* Upper triangular matrix -* - DO 70 J = 1, N - DO 60 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* Upper Hessenberg matrix -* - DO 90 J = 1, N - DO 80 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( ITYPE.EQ.4 ) THEN -* -* Lower half of a symmetric band matrix -* - K3 = KL + 1 - K4 = N + 1 - DO 110 J = 1, N - DO 100 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 100 CONTINUE - 110 CONTINUE -* - ELSE IF( ITYPE.EQ.5 ) THEN -* -* Upper half of a symmetric band matrix -* - K1 = KU + 2 - K3 = KU + 1 - DO 130 J = 1, N - DO 120 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 120 CONTINUE - 130 CONTINUE -* - ELSE IF( ITYPE.EQ.6 ) THEN -* -* Band matrix -* - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 150 J = 1, N - DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -* - END IF -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DLASCL -* - END SUBROUTINE DLASCL - -! ################################################################################################################################## -! 053 LAPACK_BLAS_AUX - - SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, M, N - REAL(DOUBLE) ALPHA, BETA -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASET initializes an m-by-n matrix A to BETA on the diagonal and -* ALPHA on the offdiagonals. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies the part of the matrix A to be set. -* = 'U': Upper triangular part is set; the strictly lower -* triangular part of A is not changed. -* = 'L': Lower triangular part is set; the strictly upper -* triangular part of A is not changed. -* Otherwise: All of the matrix A is set. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* ALPHA (input) REAL(DOUBLE) -* The constant to which the offdiagonal elements are to be set. -* -* BETA (input) REAL(DOUBLE) -* The constant to which the diagonal elements are to be set. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On exit, the leading m-by-n submatrix of A is set as follows: -* -* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, -* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, -* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, -* -* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Set the strictly upper triangular or trapezoidal part of the -* array to ALPHA. -* - DO 20 J = 2, N - DO 10 I = 1, MIN( J-1, M ) - A( I, J ) = ALPHA - 10 CONTINUE - 20 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN -* -* Set the strictly lower triangular or trapezoidal part of the -* array to ALPHA. -* - DO 40 J = 1, MIN( M, N ) - DO 30 I = J + 1, M - A( I, J ) = ALPHA - 30 CONTINUE - 40 CONTINUE -* - ELSE -* -* Set the leading m-by-n submatrix to ALPHA. -* - DO 60 J = 1, N - DO 50 I = 1, M - A( I, J ) = ALPHA - 50 CONTINUE - 60 CONTINUE - END IF -* -* Set the first min(M,N) diagonal elements to BETA. -* - DO 70 I = 1, MIN( M, N ) - A( I, I ) = BETA - 70 CONTINUE -* - RETURN -* -* End of DLASET -* - END SUBROUTINE DLASET - -! ################################################################################################################################## -! 054 LAPACK_BLAS_AUX - - SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, PIVOT, SIDE - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), C( * ), S( * ) -* .. -* -* Purpose -* ======= -* -* DLASR performs the transformation -* -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) -* -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) -* -* where A is an m by n real matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): -* -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* This version vectorises across rows of the array A when SIDE = 'L'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* Specifies whether the plane rotation matrix P is applied to -* A on the left or the right. -* = 'L': Left, compute A := P*A -* = 'R': Right, compute A:= A*P' -* -* DIRECT (input) CHARACTER*1 -* Specifies whether P is a forward or backward sequence of -* plane rotations. -* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) -* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) -* -* PIVOT (input) CHARACTER*1 -* Specifies the plane for which P(k) is a plane rotation -* matrix. -* = 'V': Variable pivot, the plane (k,k+1) -* = 'T': Top pivot, the plane (1,k+1) -* = 'B': Bottom pivot, the plane (k,z) -* -* M (input) INTEGER -* The number of rows of the matrix A. If m <= 1, an immediate -* return is effected. -* -* N (input) INTEGER -* The number of columns of the matrix A. If n <= 1, an -* immediate return is effected. -* -* C, S (input) REAL(DOUBLE) arrays, dimension -* (M-1) if SIDE = 'L' -* (N-1) if SIDE = 'R' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, J - REAL(DOUBLE) CTEMP, STEMP, TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = 1 - ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, - $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN - INFO = 2 - ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) - $ THEN - INFO = 3 - ELSE IF( M.LT.0 ) THEN - INFO = 4 - ELSE IF( N.LT.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASR ', INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form P * A -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 10 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 40 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 30 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 60 J = 2, M - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 50 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 80 J = M, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 70 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 100 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 90 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 90 CONTINUE - END IF - 100 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 120 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 110 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form A * P' -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 140 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 130 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 130 CONTINUE - END IF - 140 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 160 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 150 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 150 CONTINUE - END IF - 160 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 180 J = 2, N - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 170 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 200 J = N, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 190 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 190 CONTINUE - END IF - 200 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 220 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 210 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 210 CONTINUE - END IF - 220 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 240 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 230 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 230 CONTINUE - END IF - 240 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DLASR -* - END SUBROUTINE DLASR - -! ################################################################################################################################## -! 055 LAPACK_BLAS_AUX - - SUBROUTINE DLASRT( ID, N, D, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER ID - INTEGER INFO, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) D( * ) -* .. -* -* Purpose -* ======= -* -* Sort the numbers in D in increasing order (if ID = 'I') or -* in decreasing order (if ID = 'D' ). -* -* Use Quick Sort, reverting to Insertion sort on arrays of -* size <= 20. Dimension of STACK limits N to about 2**32. -* -* Arguments -* ========= -* -* ID (input) CHARACTER*1 -* = 'I': sort D in increasing order; -* = 'D': sort D in decreasing order. -* -* N (input) INTEGER -* The length of the array D. -* -* D (input/output) REAL(DOUBLE) array, dimension (N) -* On entry, the array to be sorted. -* On exit, D has been sorted into increasing order -* (D(1) <= ... <= D(N) ) or into decreasing order -* (D(1) >= ... >= D(N) ), depending on ID. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER SELECT - PARAMETER ( SELECT = 20 ) -* .. -* .. Local Scalars .. - INTEGER DIR, ENDD, I, J, START, STKPNT - REAL(DOUBLE) D1, D2, D3, DMNMX, TMP -* .. -* .. Local Arrays .. - INTEGER STACK( 2, 32 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Executable Statements .. -* -* Test the input paramters. -* - INFO = 0 - DIR = -1 - IF( LSAME( ID, 'D' ) ) THEN - DIR = 0 - ELSE IF( LSAME( ID, 'I' ) ) THEN - DIR = 1 - END IF - IF( DIR.EQ.-1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASRT', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* - STKPNT = 1 - STACK( 1, 1 ) = 1 - STACK( 2, 1 ) = N - 10 CONTINUE - START = STACK( 1, STKPNT ) - ENDD = STACK( 2, STKPNT ) - STKPNT = STKPNT - 1 - IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN -* -* Do Insertion sort on D( START:ENDD ) -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - DO 30 I = START + 1, ENDD - DO 20 J = I, START + 1, -1 - IF( D( J ).GT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 30 - END IF - 20 CONTINUE - 30 CONTINUE -* - ELSE -* -* Sort into increasing order -* - DO 50 I = START + 1, ENDD - DO 40 J = I, START + 1, -1 - IF( D( J ).LT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 50 - END IF - 40 CONTINUE - 50 CONTINUE -* - END IF -* - ELSE IF( ENDD-START.GT.SELECT ) THEN -* -* Partition D( START:ENDD ) and stack parts, largest one first -* -* Choose partition entry as median of 3 -* - D1 = D( START ) - D2 = D( ENDD ) - I = ( START+ENDD ) / 2 - D3 = D( I ) - IF( D1.LT.D2 ) THEN - IF( D3.LT.D1 ) THEN - DMNMX = D1 - ELSE IF( D3.LT.D2 ) THEN - DMNMX = D3 - ELSE - DMNMX = D2 - END IF - ELSE - IF( D3.LT.D2 ) THEN - DMNMX = D2 - ELSE IF( D3.LT.D1 ) THEN - DMNMX = D3 - ELSE - DMNMX = D1 - END IF - END IF -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - I = START - 1 - J = ENDD + 1 - 60 CONTINUE - 70 CONTINUE - J = J - 1 - IF( D( J ).LT.DMNMX ) - $ GO TO 70 - 80 CONTINUE - I = I + 1 - IF( D( I ).GT.DMNMX ) - $ GO TO 80 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 60 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - ELSE -* -* Sort into increasing order -* - I = START - 1 - J = ENDD + 1 - 90 CONTINUE - 100 CONTINUE - J = J - 1 - IF( D( J ).GT.DMNMX ) - $ GO TO 100 - 110 CONTINUE - I = I + 1 - IF( D( I ).LT.DMNMX ) - $ GO TO 110 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 90 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - END IF - END IF - IF( STKPNT.GT.0 ) - $ GO TO 10 - RETURN -* -* End of DLASRT -* - END SUBROUTINE DLASRT - -! ################################################################################################################################## -! 056 LAPACK_BLAS_AUX - - SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, N - REAL(DOUBLE) SCALE, SUMSQ -* .. -* .. Array Arguments .. - REAL(DOUBLE) X( * ) -* .. -* -* Purpose -* ======= -* -* DLASSQ returns the values scl and smsq such that -* -* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -* -* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -* assumed to be non-negative and scl returns the value -* -* scl = max( scale, abs( x( i ) ) ). -* -* scale and sumsq must be supplied in SCALE and SUMSQ and -* scl and smsq are overwritten on SCALE and SUMSQ respectively. -* -* The routine makes only one pass through the vector x. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of elements to be used from the vector X. -* -* X (input) REAL(DOUBLE) array, dimension (N) -* The vector for which a scaled sum of squares is computed. -* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. -* -* INCX (input) INTEGER -* The increment between successive values of the vector X. -* INCX > 0. -* -* SCALE (input/output) REAL(DOUBLE) -* On entry, the value scale in the equation above. -* On exit, SCALE is overwritten with scl , the scaling factor -* for the sum of squares. -* -* SUMSQ (input/output) REAL(DOUBLE) -* On entry, the value sumsq in the equation above. -* On exit, SUMSQ is overwritten with smsq , the basic sum of -* squares from which scl has been factored out. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - REAL(DOUBLE) ABSXI -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - IF( X( IX ).NE.ZERO ) THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 - SCALE = ABSXI - ELSE - SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF - RETURN -* -* End of DLASSQ -* - END SUBROUTINE DLASSQ - -! ################################################################################################################################## -! 057 LAPACK_BLAS_AUX - - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL(DOUBLE) A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - REAL(DOUBLE) TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END SUBROUTINE DLASWP - -! ################################################################################################################################## -! 058 LAPACK_BLAS_AUX - - SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, - $ SCALE, CNORM, INFO, iter_num, dtbsv_msg ) - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DLATBS' -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORMIN, TRANS, UPLO - character*1 dtbsv_msg - INTEGER INFO, KD, LDAB, N - integer iter_num - REAL(DOUBLE) SCALE -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ), CNORM( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DLATBS solves one of the triangular systems -* -* A *x = s*b or A'*x = s*b -* -* with scaling to prevent overflow, where A is an upper or lower -* triangular band matrix. Here A' denotes the transpose of A, x and b -* are n-element vectors, and s is a scaling factor, usually less than -* or equal to 1, chosen so that the components of x will be less than -* the overflow threshold. If the unscaled problem will not cause -* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A -* is singular (A(j,j) = 0 for some j), then s is set to 0 and a -* non-trivial solution to A*x = 0 is returned. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* TRANS (input) CHARACTER*1 -* Specifies the operation applied to A. -* = 'N': Solve A * x = s*b (No transpose) -* = 'T': Solve A'* x = s*b (Transpose) -* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* NORMIN (input) CHARACTER*1 -* Specifies whether CNORM has been set or not. -* = 'Y': CNORM contains the column norms on entry -* = 'N': CNORM is not set on entry. On exit, the norms will -* be computed and stored in CNORM. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of subdiagonals or superdiagonals in the -* triangular matrix A. KD >= 0. -* -* AB (input) REAL(DOUBLE) array, dimension (LDAB,N) -* The upper or lower triangular band matrix A, stored in the -* first KD+1 rows of the array. The j-th column of A is stored -* in the j-th column of the array AB as follows: -* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* X (input/output) REAL(DOUBLE) array, dimension (N) -* On entry, the right hand side b of the triangular system. -* On exit, X is overwritten by the solution vector x. -* -* SCALE (output) REAL(DOUBLE) -* The scaling factor s for the triangular system -* A * x = s*b or A'* x = s*b. -* If SCALE = 0, the matrix A is singular or badly scaled, and -* the vector x is an exact or approximate solution to A*x = 0. -* -* CNORM (input or output) REAL(DOUBLE) array, dimension (N) -* -* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) -* contains the norm of the off-diagonal part of the j-th column -* of A. If TRANS = 'N', CNORM(j) must be greater than or equal -* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) -* must be greater than or equal to the 1-norm. -* -* If NORMIN = 'N', CNORM is an output argument and CNORM(j) -* returns the 1-norm of the offdiagonal part of the j-th column -* of A. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -! iter_num (input) INTEGER -! This subr may be called iteratively (by DPBCON when -! estimating RCOND (cond number of AB) - -! dtbsv_msg (input) CHARACTER -! = 'Y', have subr DTBSV print Fwd, Back pass messages - -* Further Details -* ======= ======= -* -* A rough bound on x is computed; if that is less than overflow, DTBSV -* is called, otherwise, specific code is used which checks for possible -* overflow or divide-by-zero at every operation. -* -* A columnwise scheme is used for solving A*x = b. The basic algorithm -* if A is lower triangular is -* -* x[1:n] := b[1:n] -* for j = 1, ..., n -* x(j) := x(j) / A(j,j) -* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] -* end -* -* Define bounds on the components of x after j iterations of the loop: -* M(j) = bound on x[1:j] -* G(j) = bound on x[j+1:n] -* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. -* -* Then for iteration j+1 we have -* M(j+1) <= G(j) / | A(j+1,j+1) | -* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | -* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) -* -* where CNORM(j+1) is greater than or equal to the infinity-norm of -* column j+1 of A, not counting the diagonal. Hence -* -* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) -* 1<=i<=j -* and -* -* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) -* 1<=i< j -* -* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the -* reciprocal of the largest M(j), j=1,..,n, is larger than -* max(underflow, 1/overflow). -* -* The bound on x(j) is also used to determine when a step in the -* columnwise method can be performed without fear of overflow. If -* the computed bound is greater than a large constant, x is scaled to -* prevent overflow, but if the bound overflows, x is set to 0, x(j) to -* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. -* -* Similarly, a row-wise scheme is used to solve A'*x = b. The basic -* algorithm for A upper triangular is -* -* for j = 1, ..., n -* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) -* end -* -* We simultaneously compute two bounds -* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j -* M(j) = bound on x(i), 1<=i<=j -* -* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we -* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. -* Then the bound on x(j) is -* -* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | -* -* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) -* 1<=i<=j -* -* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater -* than max(underflow, 1/overflow). -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN, NOUNIT, UPPER - INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND - REAL(DOUBLE) BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, - $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH - -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* - - -! ********************************************************************************************************************************** -* INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOTRAN = LSAME( TRANS, 'N' ) - NOUNIT = LSAME( DIAG, 'N' ) -* -* Test the input parameters. -* - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. - $ LSAME( NORMIN, 'N' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( KD.LT.0 ) THEN - INFO = -6 - ELSE IF( LDAB.LT.KD+1 ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLATBS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine machine dependent parameters to control overflow. -* - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - SCALE = ONE -* - IF( LSAME( NORMIN, 'N' ) ) THEN -* -* Compute the 1-norm of each column, not including the diagonal. -* - IF( UPPER ) THEN -* -* A is upper triangular. -* - DO 10 J = 1, N - JLEN = MIN( KD, J-1 ) - CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 ) - 10 CONTINUE - ELSE -* -* A is lower triangular. -* - DO 20 J = 1, N - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) THEN - CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 ) - ELSE - CNORM( J ) = ZERO - END IF - 20 CONTINUE - END IF - END IF -* -* Scale the column norms by TSCAL if the maximum element in CNORM is -* greater than BIGNUM. -* - IMAX = IDAMAX( N, CNORM, 1 ) - TMAX = CNORM( IMAX ) - IF( TMAX.LE.BIGNUM ) THEN - TSCAL = ONE - ELSE - TSCAL = ONE / ( SMLNUM*TMAX ) - CALL DSCAL( N, TSCAL, CNORM, 1 ) - END IF -* -* Compute a bound on the computed solution vector to see if the -* Level 2 BLAS routine DTBSV can be used. -* - J = IDAMAX( N, X, 1 ) - XMAX = ABS( X( J ) ) - XBND = XMAX - IF( NOTRAN ) THEN -* -* Compute the growth in A * x = b. -* - IF( UPPER ) THEN - JFIRST = N - JLAST = 1 - JINC = -1 - MAIND = KD + 1 - ELSE - JFIRST = 1 - JLAST = N - JINC = 1 - MAIND = 1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 50 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, G(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 30 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* M(j) = G(j-1) / abs(A(j,j)) -* - TJJ = ABS( AB( MAIND, J ) ) - XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) - IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN -* -* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) -* - GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) - ELSE -* -* G(j) could overflow, set GROW to 0. -* - GROW = ZERO - END IF - 30 CONTINUE - GROW = XBND - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 40 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* G(j) = G(j-1)*( 1 + CNORM(j) ) -* - GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) - 40 CONTINUE - END IF - 50 CONTINUE -* - ELSE -* -* Compute the growth in A' * x = b. -* - IF( UPPER ) THEN - JFIRST = 1 - JLAST = N - JINC = 1 - MAIND = KD + 1 - ELSE - JFIRST = N - JLAST = 1 - JINC = -1 - MAIND = 1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 80 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, M(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 60 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) -* - XJ = ONE + CNORM( J ) - GROW = MIN( GROW, XBND / XJ ) -* -* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) -* - TJJ = ABS( AB( MAIND, J ) ) - IF( XJ.GT.TJJ ) - $ XBND = XBND*( TJJ / XJ ) - 60 CONTINUE - GROW = MIN( GROW, XBND ) - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 70 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = ( 1 + CNORM(j) )*G(j-1) -* - XJ = ONE + CNORM( J ) - GROW = GROW / XJ - 70 CONTINUE - END IF - 80 CONTINUE - END IF -* - IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN -* -* Use the Level 2 BLAS solve if the reciprocal of the bound on -* elements of X is not too small. -* - CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 - & , dtbsv_msg ) - ELSE -* -* Use a Level 1 BLAS solve, scaling intermediate results. -* - IF( XMAX.GT.BIGNUM ) THEN -* -* Scale X so that its components are less than or equal to -* BIGNUM in absolute value. -* - SCALE = BIGNUM / XMAX - CALL DSCAL( N, SCALE, X, 1 ) - XMAX = BIGNUM - END IF -* - IF( NOTRAN ) THEN -* -* Solve A * x = b -* - DO 110 J = JFIRST, JLAST, JINC - - write(sc1,12345,advance='no') iter_num,j,jlast,cr13_lba -* -* Compute x(j) = b(j) / A(j,j), scaling x if necessary. -* - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN - TJJS = AB( MAIND, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 100 - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by 1/b(j). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM -* to avoid overflow when dividing by A(j,j). -* - REC = ( TJJ*BIGNUM ) / XJ - IF( CNORM( J ).GT.ONE ) THEN -* -* Scale by 1/CNORM(j) to avoid overflow when -* multiplying x(j) times column j. -* - REC = REC / CNORM( J ) - END IF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A*x = 0. -* - DO 90 I = 1, N - X( I ) = ZERO - 90 CONTINUE - X( J ) = ONE - XJ = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 100 CONTINUE -* -* Scale x if necessary to avoid overflow when adding a -* multiple of column j of A. -* - IF( XJ.GT.ONE ) THEN - REC = ONE / XJ - IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN -* -* Scale x by 1/(2*abs(x(j))). -* - REC = REC*HALF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - END IF - ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN -* -* Scale x by 1/2. -* - CALL DSCAL( N, HALF, X, 1 ) - SCALE = SCALE*HALF - END IF -* - IF( UPPER ) THEN - IF( J.GT.1 ) THEN -* -* Compute the update -* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - -* x(j)* A(max(1,j-kd):j-1,j) -* - JLEN = MIN( KD, J-1 ) - CALL DAXPY( JLEN, -X( J )*TSCAL, - $ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 ) - I = IDAMAX( J-1, X, 1 ) - XMAX = ABS( X( I ) ) - END IF - ELSE IF( J.LT.N ) THEN -* -* Compute the update -* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - -* x(j) * A(j+1:min(j+kd,n),j) -* - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) - $ CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1, - $ X( J+1 ), 1 ) - I = J + IDAMAX( N-J, X( J+1 ), 1 ) - XMAX = ABS( X( I ) ) - END IF - 110 CONTINUE -* - ELSE -* -* Solve A' * x = b -* - DO 160 J = JFIRST, JLAST, JINC - - write(sc1,12345,advance='no') iter_num,j,jlast,cr13_lba -* -* Compute x(j) = b(j) - sum A(k,j)*x(k). -* k<>j -* - XJ = ABS( X( J ) ) - USCAL = TSCAL - REC = ONE / MAX( XMAX, ONE ) - IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN -* -* If x(j) could overflow, scale x by 1/(2*XMAX). -* - REC = REC*HALF - IF( NOUNIT ) THEN - TJJS = AB( MAIND, J )*TSCAL - ELSE - TJJS = TSCAL - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.ONE ) THEN -* -* Divide by A(j,j) when scaling x if A(j,j) > 1. -* - REC = MIN( ONE, REC*TJJ ) - USCAL = USCAL / TJJS - END IF - IF( REC.LT.ONE ) THEN - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF -* - SUMJ = ZERO - IF( USCAL.EQ.ONE ) THEN -* -* If the scaling needed for A in the dot product is 1, -* call DDOT to perform the dot product. -* - IF( UPPER ) THEN - JLEN = MIN( KD, J-1 ) - SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1, - $ X( J-JLEN ), 1 ) - ELSE - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) - $ SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 ) - END IF - ELSE -* -* Otherwise, use in-line code for the dot product. -* - IF( UPPER ) THEN - JLEN = MIN( KD, J-1 ) - DO 120 I = 1, JLEN - SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )* - $ X( J-JLEN-1+I ) - 120 CONTINUE - ELSE - JLEN = MIN( KD, N-J ) - DO 130 I = 1, JLEN - SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I ) - 130 CONTINUE - END IF - END IF -* - IF( USCAL.EQ.TSCAL ) THEN -* -* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) -* was not used to scale the dotproduct. -* - X( J ) = X( J ) - SUMJ - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN -* -* Compute x(j) = x(j) / A(j,j), scaling if necessary. -* - TJJS = AB( MAIND, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 150 - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale X by 1/abs(x(j)). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. -* - REC = ( TJJ*BIGNUM ) / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A'*x = 0. -* - DO 140 I = 1, N - X( I ) = ZERO - 140 CONTINUE - X( J ) = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 150 CONTINUE - ELSE -* -* Compute x(j) := x(j) / A(j,j) - sumj if the dot -* product has already been divided by 1/A(j,j). -* - X( J ) = X( J ) / TJJS - SUMJ - END IF - XMAX = MAX( XMAX, ABS( X( J ) ) ) - 160 CONTINUE - END IF - SCALE = SCALE / TSCAL - END IF -* -* Scale the column norms by 1/TSCAL for return. -* - IF( TSCAL.NE.ONE ) THEN - CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) - END IF -* -* End of DLATBS -* -12345 format(5X,'Iteration number ',i4,' : J = ',i8,' to ',i8, a) - - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DLATBS - -! ################################################################################################################################## -! 059 LAPACK_BLAS_AUX - - SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDW, N, NB -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) -* .. -* -* Purpose -* ======= -* -* DLATRD reduces NB rows and columns of a real symmetric matrix A to -* symmetric tridiagonal form by an orthogonal similarity -* transformation Q' * A * Q, and returns the matrices V and W which are -* needed to apply the transformation to the unreduced part of A. -* -* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a -* matrix, of which the upper triangle is supplied; -* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a -* matrix, of which the lower triangle is supplied. -* -* This is an auxiliary routine called by DSYTRD. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. -* -* NB (input) INTEGER -* The number of rows and columns to be reduced. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit: -* if UPLO = 'U', the last NB columns have been reduced to -* tridiagonal form, with the diagonal elements overwriting -* the diagonal elements of A; the elements above the diagonal -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors; -* if UPLO = 'L', the first NB columns have been reduced to -* tridiagonal form, with the diagonal elements overwriting -* the diagonal elements of A; the elements below the diagonal -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= (1,N). -* -* E (output) REAL(DOUBLE) array, dimension (N-1) -* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal -* elements of the last NB columns of the reduced matrix; -* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of -* the first NB columns of the reduced matrix. -* -* TAU (output) REAL(DOUBLE) array, dimension (N-1) -* The scalar factors of the elementary reflectors, stored in -* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. -* See Further Details. -* -* W (output) REAL(DOUBLE) array, dimension (LDW,NB) -* The n-by-nb matrix W required to update the unreduced part -* of A. -* -* LDW (input) INTEGER -* The leading dimension of the array W. LDW >= max(1,N). -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n) H(n-1) . . . H(n-nb+1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), -* and tau in TAU(i-1). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(nb). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), -* and tau in TAU(i). -* -* The elements of the vectors v together form the n-by-nb matrix V -* which is needed, with W, to apply the transformation to the unreduced -* part of the matrix, using a symmetric rank-2k update of the form: -* A := A - V*W' - W*V'. -* -* The contents of A on exit are illustrated by the following examples -* with n = 5 and nb = 2: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( a a a v4 v5 ) ( d ) -* ( a a v4 v5 ) ( 1 d ) -* ( a 1 v5 ) ( v1 1 a ) -* ( d 1 ) ( v1 v2 a a ) -* ( d ) ( v1 v2 a a a ) -* -* where d denotes a diagonal element of the reduced matrix, a denotes -* an element of the original matrix that is unchanged, and vi denotes -* an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IW - REAL(DOUBLE) ALPHA -* .. -* .. External Subroutines .. -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Reduce last NB columns of upper triangle -* - DO 10 I = N, N - NB + 1, -1 - IW = I - N + NB - IF( I.LT.N ) THEN -* -* Update A(1:i,i) -* - CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), - $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) - CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), - $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) - END IF - IF( I.GT.1 ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(1:i-2,i) -* - CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) - E( I-1 ) = A( I-1, I ) - A( I-1, I ) = ONE -* -* Compute W(1:i-1,i) -* - CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, - $ ZERO, W( 1, IW ), 1 ) - IF( I.LT.N ) THEN - CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), - $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, -ONE, - $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, -ONE, - $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, - $ W( 1, IW ), 1 ) - END IF - CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) - ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, - $ A( 1, I ), 1 ) - CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) - END IF -* - 10 CONTINUE - ELSE -* -* Reduce first NB columns of lower triangle -* - DO 20 I = 1, NB -* -* Update A(i:n,i) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), - $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) - IF( I.LT.N ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:n,i) -* - CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAU( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute W(i+1:n,i) -* - CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, - $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), - $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) - CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) - ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, - $ A( I+1, I ), 1 ) - CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) - END IF -* - 20 CONTINUE - END IF -* - RETURN -* -* End of DLATRD -* - END SUBROUTINE DLATRD - -! ################################################################################################################################## -! 060 LAPACK_BLAS_AUX - - SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORG2L generates an m by n real matrix Q with orthonormal columns, -* which is defined as the last n columns of a product of k elementary -* reflectors of order m -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGEQLF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the (n-k+i)-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQLF in the last k columns of its array -* argument A. -* On exit, the m by n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) REAL(DOUBLE) array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQLF. -* -* WORK (workspace) REAL(DOUBLE) array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, II, J, L -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2L', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns 1:n-k to columns of the unit matrix -* - DO 20 J = 1, N - K - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( M-N+J, J ) = ONE - 20 CONTINUE -* - DO 40 I = 1, K - II = N - K + I -* -* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left -* - A( M-N+II, II ) = ONE - CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) - CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) - A( M-N+II, II ) = ONE - TAU( I ) -* -* Set A(m-k+i+1:m,n-k+i) to zero -* - DO 30 L = M - N + II + 1, M - A( L, II ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2L -* - END SUBROUTINE DORG2L - -! ################################################################################################################################## -! 061 LAPACK_BLAS_AUX - - SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORG2R generates an m by n real matrix Q with orthonormal columns, -* which is defined as the first n columns of a product of k elementary -* reflectors of order m -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the i-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQRF in the first k columns of its array -* argument A. -* On exit, the m-by-n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) REAL(DOUBLE) array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* WORK (workspace) REAL(DOUBLE) array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2R -* - END SUBROUTINE DORG2R - -! ################################################################################################################################## -! 062 LAPACK_BLAS_AUX - - SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGQL generates an M-by-N real matrix Q with orthonormal columns, -* which is defined as the last N columns of a product of K elementary -* reflectors of order M -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGEQLF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the (n-k+i)-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQLF in the last k columns of its array -* argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) REAL(DOUBLE) array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQLF. -* -* WORK (workspace/output) REAL(DOUBLE) array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, - $ NB, NBMIN, NX -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQL', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the first block. -* The last kk columns are handled by the block method. -* - KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) -* -* Set A(m-kk+1:m,1:n-kk) to zero. -* - DO 20 J = 1, N - KK - DO 10 I = M - KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the first or only block. -* - CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = K - KK + 1, K, NB - IB = MIN( NB, K-I+1 ) - IF( N-K+I.GT.1 ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i+ib-1) . . . H(i+1) H(i) -* - CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, - $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Backward', - $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, - $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, - $ WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows 1:m-k+i+ib-1 of current block -* - CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, - $ TAU( I ), WORK, IINFO ) -* -* Set rows m-k+i+ib:m of current block to zero -* - DO 40 J = N - K + I, N - K + I + IB - 1 - DO 30 L = M - K + I + IB, M - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQL -* - END SUBROUTINE DORGQL - -! ################################################################################################################################## -! 063 LAPACK_BLAS_AUX - - SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGQR generates an M-by-N real matrix Q with orthonormal columns, -* which is defined as the first N columns of a product of K elementary -* reflectors of order M -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the i-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQRF in the first k columns of its array -* argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) REAL(DOUBLE) array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* WORK (workspace/output) REAL(DOUBLE) array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, - $ LWKOPT, NB, NBMIN, NX -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) - LWKOPT = MAX( 1, N )*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQR', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQR -* - END SUBROUTINE DORGQR - -! ################################################################################################################################## -! 064 LAPACK_BLAS_AUX - - SUBROUTINE DRSCL( N, SA, SX, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INCX, N - REAL(DOUBLE) SA -* .. -* .. Array Arguments .. - REAL(DOUBLE) SX( * ) -* .. -* -* Purpose -* ======= -* -* DRSCL multiplies an n-element real vector x by the real scalar 1/a. -* This is done without overflow or underflow as long as -* the final result x/a does not overflow or underflow. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of components of the vector x. -* -* SA (input) REAL(DOUBLE) -* The scalar a which is used to divide each component of x. -* SA must be >= 0, or the subroutine will divide by zero. -* -* SX (input/output) REAL(DOUBLE) array, dimension -* (1+(N-1)*abs(INCX)) -* The n-element vector x. -* -* INCX (input) INTEGER -* The increment between successive values of the vector SX. -* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - REAL(DOUBLE) BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM -* .. -* .. External Functions .. - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Initialize the denominator to SA and the numerator to 1. -* - CDEN = SA - CNUM = ONE -* - 10 CONTINUE - CDEN1 = CDEN*SMLNUM - CNUM1 = CNUM / BIGNUM - IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN -* -* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. -* - MUL = SMLNUM - DONE = .FALSE. - CDEN = CDEN1 - ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN -* -* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. -* - MUL = BIGNUM - DONE = .FALSE. - CNUM = CNUM1 - ELSE -* -* Multiply X by CNUM / CDEN and return. -* - MUL = CNUM / CDEN - DONE = .TRUE. - END IF -* -* Scale the vector X by MUL -* - CALL DSCAL( N, MUL, SX, INCX ) -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DRSCL -* - END SUBROUTINE DRSCL - -! ################################################################################################################################## -! 065 LAPACK_BLAS_AUX - - SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), D( * ), E( * ), TAU( * ) -* .. -* -* Purpose -* ======= -* -* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal -* form T by an orthogonal similarity transformation: Q' * A * Q = T. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit, if UPLO = 'U', the diagonal and first superdiagonal -* of A are overwritten by the corresponding elements of the -* tridiagonal matrix T, and the elements above the first -* superdiagonal, with the array TAU, represent the orthogonal -* matrix Q as a product of elementary reflectors; if UPLO -* = 'L', the diagonal and first subdiagonal of A are over- -* written by the corresponding elements of the tridiagonal -* matrix T, and the elements below the first subdiagonal, with -* the array TAU, represent the orthogonal matrix Q as a product -* of elementary reflectors. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* D (output) REAL(DOUBLE) array, dimension (N) -* The diagonal elements of the tridiagonal matrix T: -* D(i) = A(i,i). -* -* E (output) REAL(DOUBLE) array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix T: -* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -* -* TAU (output) REAL(DOUBLE) array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n-1) . . . H(2) H(1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -* A(1:i-1,i+1), and tau in TAU(i). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(n-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -* and tau in TAU(i). -* -* The contents of A on exit are illustrated by the following examples -* with n = 5: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( d e v2 v3 v4 ) ( d ) -* ( d e v3 v4 ) ( e d ) -* ( d e v4 ) ( v1 e d ) -* ( d e ) ( v1 v2 e d ) -* ( d ) ( v1 v2 v3 e d ) -* -* where d and e denote diagonal and off-diagonal elements of T, and vi -* denotes an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO, HALF - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, - $ HALF = 1.0D0 / 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - REAL(DOUBLE) ALPHA, TAUI -* .. -* .. External Subroutines .. -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTD2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A -* - DO 10 I = N - 1, 1, -1 -* -* Generate elementary reflector H(i) = I - tau * v * v' -* to annihilate A(1:i-1,i+1) -* - CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) - E( I ) = A( I, I+1 ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(1:i,1:i) -* - A( I, I+1 ) = ONE -* -* Compute x := tau * A * v storing x in TAU(1:i) -* - CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, - $ TAU, 1 ) -* -* Compute w := x - 1/2 * tau * (x'*v) * v -* - ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) - CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w' - w * v' -* - CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, - $ LDA ) -* - A( I, I+1 ) = E( I ) - END IF - D( I+1 ) = A( I+1, I+1 ) - TAU( I ) = TAUI - 10 CONTINUE - D( 1 ) = A( 1, 1 ) - ELSE -* -* Reduce the lower triangle of A -* - DO 20 I = 1, N - 1 -* -* Generate elementary reflector H(i) = I - tau * v * v' -* to annihilate A(i+2:n,i) -* - CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, - $ TAUI ) - E( I ) = A( I+1, I ) -* - IF( TAUI.NE.ZERO ) THEN -* -* Apply H(i) from both sides to A(i+1:n,i+1:n) -* - A( I+1, I ) = ONE -* -* Compute x := tau * A * v storing y in TAU(i:n-1) -* - CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, - $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) -* -* Compute w := x - 1/2 * tau * (x'*v) * v -* - ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), - $ 1 ) - CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) -* -* Apply the transformation as a rank-2 update: -* A := A - v * w' - w * v' -* - CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, - $ A( I+1, I+1 ), LDA ) -* - A( I+1, I ) = E( I ) - END IF - D( I ) = A( I, I ) - TAU( I ) = TAUI - 20 CONTINUE - D( N ) = A( N, N ) - END IF -* - RETURN -* -* End of DSYTD2 -* - END SUBROUTINE DSYTD2 - -! ################################################################################################################################# -! 069 LAPACK_BLAS_AUX - - LOGICAL FUNCTION DISNAN(DIN) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DIN -* .. -* -* Purpose -* ======= -* -* DISNAN returns .TRUE. if its argument is NaN, and .FALSE. -* otherwise. To be replaced by the Fortran 2003 intrinsic in the -* future. -* -* Arguments -* ========= -* -* DIN (input) DOUBLE PRECISION -* Input to test for NaN. -* -* ===================================================================== -* -* .. External Functions .. -* .. -* .. Executable Statements .. - DISNAN = DLAISNAN(DIN,DIN) - RETURN - END FUNCTION DISNAN - -! ################################################################################################################################# -! 070 LAPACK_BLAS_AUX - - LOGICAL FUNCTION DLAISNAN(DIN1,DIN2) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - DOUBLE PRECISION DIN1,DIN2 -* .. -* -* Purpose -* ======= -* -* This routine is not for general use. It exists solely to avoid -* over-optimization in DISNAN. -* -* DLAISNAN checks for NaNs by comparing its two arguments for -* inequality. NaN is the only floating-point value where NaN != NaN -* returns .TRUE. To check for NaNs, pass the same variable as both -* arguments. -* -* Strictly speaking, Fortran does not allow aliasing of function -* arguments. So a compiler must assume that the two arguments are -* not the same variable, and the test will not be optimized away. -* Interprocedural or whole-program optimization may delete this -* test. The ISNAN functions will be replaced by the correct -* Fortran 03 intrinsic once the intrinsic is widely available. -* -* Arguments -* ========= -* -* DIN1 (input) DOUBLE PRECISION -* DIN2 (input) DOUBLE PRECISION -* Two numbers to compare for inequality. -* -* ===================================================================== -* -* .. Executable Statements .. - DLAISNAN = (DIN1.NE.DIN2) - RETURN - END FUNCTION DLAISNAN - - END MODULE LAPACK_BLAS_AUX diff --git a/Source/Modules/LAPACK/LAPACK_GIV_MGIV_EIG.f b/Source/Modules/LAPACK/LAPACK_GIV_MGIV_EIG.f deleted file mode 100644 index ffe588a8..00000000 --- a/Source/Modules/LAPACK/LAPACK_GIV_MGIV_EIG.f +++ /dev/null @@ -1,4094 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_GIV_MGIV_EIG - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR, LINKNO - USE TIMDAT, ONLY : TSEC - USE LAPACK_BLAS_AUX - USE LAPACK_MISCEL ! This contains DSTEQR, used in this module - - USE OURTIM_Interface - USE OUTA_HERE_Interface - USE LINK_MESSAGE_Interface - - character(1*byte), parameter :: cr13_lge = char(13) - -! This is a set of LAPACK routines for solving for all, or some, eigenvalues and, possibly, some eigenvectors of: - -! Ax = (Lambda)Bx (1) - -! where A and B are real and symmetric. - -! This module contains the major LAPACK subroutines described below (and contained in this module): - -! DSBGVX_GIV_MGIV : Main driver for solving (1) for eigenvalues and eigenvectors, This driver calls: - -! DPBSTF: to form split Cholesky factorization of B. - -! DSBGST: to transform problem from from Ax = (Lambda)Bx to std eigen problem Cy = (Lambda)y. This subr calls: - -! DSBTRD: to reduce the symmetric band matrix C to a symmetric tridiagonal form by orthogonal similarity transforms. - -! In the case where all eigenvalues and, possibly all eigenvecs are requested, the driver calls 1 or all of the following subr's: - -! DSTERF: to compute all eigenvalues of the tridiagonal matrix. -! NOTE: DSTERF is not in this module, it is in module LAPACK_MISCEL, since it is used in several modules -! or -! DSTEQR: to compute all eigenvalues and all eigenvectors of the tridiagonal matrix (if eigenvectors are requested). -! NOTE: DSTEQR is not in this module, it is in module LAPACK_MISCEL, since it is used in several modules - -! or, in the case where some eigenvalues and, possibly some eigenvectors are requested, the driver calls one or both of the subr's: - -! DSTEBZ: to compute some eigenvalues of the tridiagonal matrix - -! then, if vectors are requested: - -! DSTEIN: to compute the eigenvectors corresponding to the eigenvalues computed by subr DSTEBZ. This subr calls: - -! DLAGTF: to factorize the matrix (T - Lambds*I) where T is the tridiagonal matrix - -! In addition, other LAPACK (BLAS) procedures are called by the above and are contained in module LAPACK_BLAS_AUX_1 - - CONTAINS - -! ################################################################################################################################## -! 001 LAPACK_FIV_MGIV_EIG - - SUBROUTINE DSBGVX_GIV_MGIV ( JOBZ, RANGE, UPLO, N, KA, KB, AB, - & LDAB, BB, LDBB, Q, LDQ, VL, VU, - & IL, IU, ABSTOL, mlam, W, Z, LDZ, - & WORK, IWORK, IFAIL, INFO, - & method, eig_num, mvec ) -* - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE PARAMS, ONLY : SUPINFO, NOCOUNTS - USE SCONTR, ONLY : SOL_NAME - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSBGVX_GIV_MGIV' - -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, RANGE, UPLO - character*8 method - INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, - $ mlam, n, eig_num(n), mvec - REAL(DOUBLE) ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IFAIL( * ), IWORK( * ) - REAL(DOUBLE) AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), - $ W( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSBGVX computes selected eigenvalues, and optionally, eigenvectors -* of a real generalized symmetric-definite banded eigenproblem, of -* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric -* and banded, and B is also positive definite. Eigenvalues and -* eigenvectors can be selected by specifying either all eigenvalues, -* a range of values or a range of indices for the desired eigenvalues. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* RANGE (input) CHARACTER*1 -* = 'A': all eigenvalues will be found. -* = 'V': all eigenvalues in the half-open interval (VL,VU] -* will be found. -* = 'I': the IL-th through IU-th eigenvalues will be found. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangles of A and B are stored; -* = 'L': Lower triangles of A and B are stored. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* KA (input) INTEGER -* The number of superdiagonals of the matrix A if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KA >= 0. -* -* KB (input) INTEGER -* The number of superdiagonals of the matrix B if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KB >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB, N) -* On entry, the upper or lower triangle of the symmetric band -* matrix A, stored in the first ka+1 rows of the array. The -* j-th column of A is stored in the j-th column of the array AB -* as follows: -* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). -* -* On exit, the contents of AB are destroyed. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KA+1. -* -* BB (input/output) REAL(DOUBLE) array, dimension (LDBB, N) -* On entry, the upper or lower triangle of the symmetric band -* matrix B, stored in the first kb+1 rows of the array. The -* j-th column of B is stored in the j-th column of the array BB -* as follows: -* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; -* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). -* -* On exit, the factor S from the split Cholesky factorization -* B = S**T*S, as returned by DPBSTF. -* -* LDBB (input) INTEGER -* The leading dimension of the array BB. LDBB >= KB+1. -* -* Q (output) REAL(DOUBLE) array, dimension (LDQ, N) -* If JOBZ = 'V', the n-by-n matrix used in the reduction of -* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, -* and consequently C to tridiagonal form. -* If JOBZ = 'N', the array Q is not referenced. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. If JOBZ = 'N', -* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). -* -* VL (input) REAL(DOUBLE) -* VU (input) REAL(DOUBLE) -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. VL < VU. -* Not referenced if RANGE = 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 0 <= IL <= IU; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'V'. -* -* ABSTOL (input) REAL(DOUBLE) -* The absolute error tolerance for the eigenvalues. -* An approximate eigenvalue is accepted as converged -* when it is determined to lie in an interval [a,b] -* of width less than or equal to -* -* ABSTOL + EPS * max( |a|,|b| ) , -* -* where EPS is the machine precision. If ABSTOL is less than -* or equal to zero, then EPS*|T| will be used in its place, -* where |T| is the 1-norm of the tridiagonal matrix obtained -* by reducing A to tridiagonal form. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* If this routine returns with INFO>0, indicating that some -* eigenvectors did not converge, try setting ABSTOL to -* 2*DLAMCH('S'). -* -* mlam (output) INTEGER -* The total number of eigenvalues found. 0 <= mlam <= N. -* If RANGE = 'I', mlam = IU-IL+1. -* -* W (output) REAL(DOUBLE) array, dimension (N) -* If INFO = 0, the eigenvalues in ascending order. -* -* Z (output) REAL(DOUBLE) array, dimension (LDZ, N) -* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of -* eigenvectors, with the i-th column of Z holding the -* eigenvector associated with W(i). The eigenvectors are -* normalized so Z**T*B*Z = I. -* If JOBZ = 'N', then Z is not referenced. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace/output) REAL(DOUBLE) array, dimension (7N) -* -* IWORK (workspace/output) INTEGER array, dimension (5N) -* -* IFAIL (input) INTEGER array, dimension (mlam) -* If JOBZ = 'V', then if INFO = 0, the first mlam elements of -* IFAIL are zero. If INFO > 0, then IFAIL contains the -* indices of the eigenvalues that failed to converge. -* If JOBZ = 'N', then IFAIL is not referenced. -* -* INFO (output) INTEGER -* = 0 : successful exit -* < 0 : if INFO = -i, the i-th argument had an illegal value -* <= N: if INFO = i, then i eigenvectors failed to converge. -* Their indices are stored in IFAIL. -* > N : DPBSTF returned an error code; i.e., -* if INFO = N + i, for 1 <= i <= N, then the leading -* minor of order i of B is not positive definite. -* The factorization of B could not be completed and -* no eigenvalues or eigenvectors were computed. - -! method (input) character*8 = 'GIV' or 'MGIV' - -! mvec (output) INTEGER, number of eigenvectors found - -! eig_num (output) Integer array (dim N) of mode numbers - -* -* Further Details -* =============== -* -* Based on contributions by -* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ - CHARACTER ORDER, VECT - character*6 sub_nam - INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP, - $ INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT - integer lowest_mode_num, highest_mode_num, pm, qm, m1 - REAL(DOUBLE) TMP1 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. - -! Initialize eig_num - - do i=1,n - eig_num(i) = 0 - enddo -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - ALLEIG = LSAME( RANGE, 'A' ) - VALEIG = LSAME( RANGE, 'V' ) - INDEIG = LSAME( RANGE, 'I' ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( KA.LT.0 ) THEN - INFO = -5 - ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN - INFO = -6 - ELSE IF( LDAB.LT.KA+1 ) THEN - INFO = -8 - ELSE IF( LDBB.LT.KB+1 ) THEN - INFO = -10 - ELSE IF( LDQ.LT.1 ) THEN - INFO = -12 - ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN - INFO = -14 - ELSE IF( INDEIG .AND. IL.LT.0 ) THEN - INFO = -15 - ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) ) ) THEN - INFO = -16 - ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN - INFO = -21 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSBGVX_GIV_MGIV', -INFO ) - END IF -* -* Form a split Cholesky factorization of B. -* - if (method(1:3) == 'GIV') then - if (sol_name(1:8) == 'BUCKLING') then - CALL LINK_MESSAGE( - $ ' CHOLESKY FACTORIZATION OF DIFFER STIFF MATRIX') - else - CALL LINK_MESSAGE( - $ ' CHOLESKY FACTORIZATION OF MASS MATRIX') - endif - else if (method(1:4) == 'MGIV') then - CALL LINK_MESSAGE(' CHOLESKY FACTORIZATION OF STIFF MATRIX') - endif - CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO ) - IF( INFO.NE.0 ) THEN - INFO = N + INFO - RETURN - END IF -* -* Transform problem to standard eigenvalue problem. -* - CALL LINK_MESSAGE(' TRANSFORM TO STANDARD EIGENVALUE PROBLEM') - CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, - $ WORK, IINFO ) -* -* Reduce symmetric band matrix to tridiagonal form. -* - CALL LINK_MESSAGE(' REDUCE SYMM BAND MATRIX TO TRIDIAG FORM') - INDD = 1 - INDE = INDD + N - INDWRK = INDE + N - IF( WANTZ ) THEN - VECT = 'U' - ELSE - VECT = 'N' - END IF - CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ), - $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO ) -* -* If all eigenvalues are desired and ABSTOL is less than or equal -* to zero, then call: -! DSTERF (eigenvalues only) or -! DSTEQR (eigenvalues and eigenvectors). -! If this fails for some eigenvalue, then try DSTEBZ. -* - IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.ge.N ) ) .AND. - $ ( ABSTOL.LE.ZERO ) ) THEN - CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) - INDEE = INDWRK + 2*N - CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - IF( .NOT.WANTZ ) THEN - sub_nam = 'DSTERF' - CALL DSTERF( N, W, WORK( INDEE ), INFO ) - ELSE - CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) - sub_nam = 'DSTEQR' - CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, - $ WORK( INDWRK ), INFO ) - IF( INFO.EQ.0 ) THEN - DO 10 I = 1, N - IFAIL( I ) = 0 - 10 CONTINUE - END IF - END IF - - do i=1,n - eig_num = i - enddo - - IF( INFO.EQ.0 ) THEN - mlam = N - mvec = N - GO TO 30 - END IF - INFO = 0 - END IF -* -* Otherwise, call DSTEBZ and, if eigenvectors are desired, -* call DSTEIN. -! /////////////////////////////////////////////////////////////////////B -* If we got here, then 1 of 2 things happened: -! (a) all eigenvalues were requested and ABSTOL <= 0, and subrs DSTERF -! (or DSTEQR), above, failed to find all of them (INFO > 0). -! If INFO > 0, LAPACK will attempt to use subrs DSTEBZ and DSTEIN -! to find the eigenvalues/vectors -! (b) all eigenvalues were not requested and subrs DSTEBZ and DSTEIN -! will be called to find them -! At any rate, print message if INFO > 0 - - if (info > 0) then - Write(err,9901) info - if (supinfo == 'N') then - Write(f06,9901) info - endif - endif - 9901 format(' *INFORMATION: LAPACK SUBR DSTERF OR DSTEQR HAS FAILED TO - &FIND ALL OF THE EIGENVALUES IN A TOTAL OF 30*NDOFA ITERATIONS' - &,/,14X,' A TOTAL OF ',I8,' SUB-DIAGONAL ELEMENTS OF THE TRIDIAGONA - &L MATRIX E HAVE NOT CONVERGED TO ZERO.' - &,/,14X,' LAPACK WILL ATTEMPT TO USE SUBR DSTEBZ TO FIND THE EIGENV - &ALUES.',/) -! /////////////////////////////////////////////////////////////////////E -! - IF( WANTZ ) THEN - ORDER = 'B' - ELSE - ORDER = 'E' - END IF - INDIBL = 1 - INDISP = INDIBL + N - INDIWO = INDISP + N - sub_nam = 'DSTEBZ' - CALL DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, - $ WORK( INDD ), WORK( INDE ), mlam, NSPLIT, W, - $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), - $ IWORK( INDIWO ), INFO, - & lowest_mode_num, highest_mode_num ) - -! /////////////////////////////////////////////////////////////////////B - if (info > 0) then ! Call routine to print message - call eigenvalue_convergence_failure ( range, info ) - if ((info == 1) .or. (info == 3) .and. (range /= 'I')) then - Write(f06,9903) - do i=1,mlam - if (iwork(indibl-1+i) < 0) then - Write(f06,9904) i,w(i) - endif - enddo - Write(f06,*) - endif - endif - 9903 format(15x,'THE EIGENVALUES OF QUESTIONABLE VALUE ARE',/, - & 15X,' INDEX EIGENVALUE') - 9904 FORMAT(15X,I8,1ES15.6) -! /////////////////////////////////////////////////////////////////////E - - do i=1,mlam - if (method(1:3) == 'GIV') then - eig_num(i) = lowest_mode_num + (i - 1) - else - eig_num(i) = (n + 1) - (lowest_mode_num + (i - 1)) - endif - enddo -* - IF( WANTZ ) THEN - sub_nam = 'DSTEIN' - mvec = mlam - CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), mvec, W, - $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, - $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) -* -* Apply transformation matrix used in reduction to tridiagonal -* form to eigenvectors returned by DSTEIN. -* - DO 20 J = 1, mvec - CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) - CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, - $ Z( 1, J ), 1 ) - 20 CONTINUE - END IF - - 30 CONTINUE - -* -* If eigenvalues are not in order, then sort them, along with -* eigenvectors. -* - IF( WANTZ ) THEN - DO 50 J = 1, mvec - 1 - I = 0 - TMP1 = W( J ) - DO 40 JJ = J + 1, mvec - IF( W( JJ ).LT.TMP1 ) THEN - I = JJ - TMP1 = W( JJ ) - END IF - 40 CONTINUE -* - IF( I.NE.0 ) THEN - ITMP1 = IWORK( INDIBL+I-1 ) - W( I ) = W( J ) - IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) - W( J ) = TMP1 - IWORK( INDIBL+J-1 ) = ITMP1 - CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) - IF( INFO.NE.0 ) THEN - ITMP1 = IFAIL( I ) - IFAIL( I ) = IFAIL( J ) - IFAIL( J ) = ITMP1 - END IF - END IF - 50 CONTINUE - END IF - - RETURN -* -* End of DSBGVX -* - END SUBROUTINE DSBGVX_GIV_MGIV - -! ################################################################################################################################## -! 002 LAPACK_GIV_MGIV_EIG - - SUBROUTINE EIGENVALUE_CONVERGENCE_FAILURE ( RANGE, INFO ) - - USE PARAMS, ONLY : SUPINFO - - character range - - integer info - - Write(err,9902) - if (supinfo == 'N') then - Write(f06,9902) - endif - - if ((info == 1) .or. (info == 3) .and. (range /= 'I')) then - Write(err,99021) - Write(f06,99021) - else if ((info == 2) .or. (info == 3) .and. (range == 'I')) then - Write(err,99022) - Write(f06,99022) - else if (( info == 4) .and. (range == 'I')) then - Write(err,803) - Write(f06,803) - fatal_err = fatal_err + 1 - call outa_here ( 'Y' ) - endif - - 9902 format(' *INFORMATION: SOME OR ALL OF THE EIGENVALUES FAILED TO CO - &NVERGE OR WERE NOT COMPUTED IN LAPACK SUBROUTINE DSTEBZ:') - -99021 format(15x,'BISECTION FAILED TO CONVERGE FOR SOME EIGENVALUES; THE - &SE EIGENVALUES ARE FLAGGED BY A NEGATIVE BLOCK NUMBER.',/,15X, - &'THE EFFECT IS THAT THE EIGENVALUES MAY NOT BE AS ACCURATE AS THE - &ABSOLUTE AND RELATIVE TOLERANCES.',/,15X, - &'THIS IS GENERALLY CAUSED BY UNEXPECTEDLY INACCURATE ARITHMETIC.' - &,/) - -99022 format(15x,'NOT ALL OF THE EIGENVALUES IN THE RANGE REQUESTED WERE - & FOUND:',/,15X, - &'CAUSE: NON-MONOTONIC ARITHMETIC, CAUSING THE STURM SEQUENCE TO BE - & NON-MONOTONIC.',/,15X, - &'CURE : RECALCULATE, REQUESTING ALL EIGENVALUES',/) - - 803 format(' *ERROR 803: PROGRAMMING ERROR IN SUBROUTINE DSTEBZ.' - &,/,15X,'NO EIGENVALUES WERE COMPUTED BY LAPACK SUBROUTINE DSTEBZ. - &THE GERSHGORIN INTERVAL INITIALLY USED WAS TOO SMALL.',/,15X, - &'PROBABLE CAUSE: YOUR MACHINE HAS SLOPPY FLOATING-POINT ARITHMETIC - &',/,15X,'CURE : INCREASE THE PARAMETER "FUDGE" IN LAPACK - &SUBROUTINE DSTEBZ, RECOMPILE, AND TRY AGAIN',/) - - END SUBROUTINE EIGENVALUE_CONVERGENCE_FAILURE -! ################################################################################################################################## -! 003 LAPACK_GIV_MGIV_EIG - - SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPDSTF' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, KD, LDAB, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* DPBSTF computes a split Cholesky factorization of a real -* symmetric positive definite band matrix A. -* -* This routine is designed to be used in conjunction with DSBGST. -* -* The factorization has the form A = S**T*S where S is a band matrix -* of the same bandwidth as A and the following structure: -* -* S = ( U ) -* ( M L ) -* -* where U is upper triangular of order m = (n+kd)/2, and L is lower -* triangular of order n-m. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of superdiagonals of the matrix A if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KD >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB,N) -* On entry, the upper or lower triangle of the symmetric band -* matrix A, stored in the first kd+1 rows of the array. The -* j-th column of A is stored in the j-th column of the array AB -* as follows: -* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -* -* On exit, if INFO = 0, the factor S from the split Cholesky -* factorization A = S**T*S. See Further Details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the factorization could not be completed, -* because the updated element a(i,i) was negative; the -* matrix A is not positive definite. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* N = 7, KD = 2: -* -* S = ( s11 s12 s13 ) -* ( s22 s23 s24 ) -* ( s33 s34 ) -* ( s44 ) -* ( s53 s54 s55 ) -* ( s64 s65 s66 ) -* ( s75 s76 s77 ) -* -* If UPLO = 'U', the array AB holds: -* -* on entry: on exit: -* -* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 -* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 -* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 -* -* If UPLO = 'L', the array AB holds: -* -* on entry: on exit: -* -* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 -* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * -* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * -* -* Array elements marked * are not used by the routine. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, KLD, KM, M - REAL(DOUBLE) AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KD.LT.0 ) THEN - INFO = -3 - ELSE IF( LDAB.LT.KD+1 ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPBSTF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - KLD = MAX( 1, LDAB-1 ) -* -* Set the splitting point m. -* - M = ( N+KD ) / 2 -* - IF( UPPER ) THEN -* -* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). -* - DO 10 J = N, M + 1, -1 -* -* Compute s(j,j) and test for non-positive-definiteness. -* - AJJ = AB( KD+1, J ) - IF( AJJ.LE.ZERO ) - $ GO TO 50 - AJJ = SQRT( AJJ ) - AB( KD+1, J ) = AJJ - KM = MIN( J-1, KD ) -* -* Compute elements j-km:j-1 of the j-th column and update the -* the leading submatrix within the band. -* - CALL DSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 ) - CALL DSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1, - $ AB( KD+1, J-KM ), KLD ) - 10 CONTINUE -* -* Factorize the updated submatrix A(1:m,1:m) as U**T*U. -* - DO 20 J = 1, M -* -* Compute s(j,j) and test for non-positive-definiteness. -* - AJJ = AB( KD+1, J ) - IF( AJJ.LE.ZERO ) - $ GO TO 50 - AJJ = SQRT( AJJ ) - AB( KD+1, J ) = AJJ - KM = MIN( KD, M-J ) -* -* Compute elements j+1:j+km of the j-th row and update the -* trailing submatrix within the band. -* - IF( KM.GT.0 ) THEN - CALL DSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD ) - CALL DSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD, - $ AB( KD+1, J+1 ), KLD ) - END IF - 20 CONTINUE - ELSE -* -* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). -* - DO 30 J = N, M + 1, -1 -* -* Compute s(j,j) and test for non-positive-definiteness. -* - AJJ = AB( 1, J ) - IF( AJJ.LE.ZERO ) - $ GO TO 50 - AJJ = SQRT( AJJ ) - AB( 1, J ) = AJJ - KM = MIN( J-1, KD ) -* -* Compute elements j-km:j-1 of the j-th row and update the -* trailing submatrix within the band. -* - CALL DSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD ) - CALL DSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD, - $ AB( 1, J-KM ), KLD ) - 30 CONTINUE -* -* Factorize the updated submatrix A(1:m,1:m) as U**T*U. -* - DO 40 J = 1, M -* -* Compute s(j,j) and test for non-positive-definiteness. -* - AJJ = AB( 1, J ) - IF( AJJ.LE.ZERO ) - $ GO TO 50 - AJJ = SQRT( AJJ ) - AB( 1, J ) = AJJ - KM = MIN( KD, M-J ) -* -* Compute elements j+1:j+km of the j-th column and update the -* trailing submatrix within the band. -* - IF( KM.GT.0 ) THEN - CALL DSCAL( KM, ONE / AJJ, AB( 2, J ), 1 ) - CALL DSYR( 'Lower', KM, -ONE, AB( 2, J ), 1, - $ AB( 1, J+1 ), KLD ) - END IF - 40 CONTINUE - END IF - RETURN -* - 50 CONTINUE - INFO = J - - RETURN -* -* End of DPBSTF -* - END SUBROUTINE DPBSTF - -! ################################################################################################################################## -! 004 LAPACK_GIV_MGIV_EIG - - SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, - $ LDX, WORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSBGST' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO, VECT - INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ), BB( LDBB, * ), WORK( * ), - $ X( LDX, * ) -* .. -* -* Purpose -* ======= -* -* DSBGST reduces a real symmetric-definite banded generalized -* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, -* such that C has the same bandwidth as A. -* -* B must have been previously factorized as S**T*S by DPBSTF, using a -* split Cholesky factorization. A is overwritten by C = X**T*A*X, where -* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the -* bandwidth of A. -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* = 'N': do not form the transformation matrix X; -* = 'V': form X. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrices A and B. N >= 0. -* -* KA (input) INTEGER -* The number of superdiagonals of the matrix A if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KA >= 0. -* -* KB (input) INTEGER -* The number of superdiagonals of the matrix B if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB,N) -* On entry, the upper or lower triangle of the symmetric band -* matrix A, stored in the first ka+1 rows of the array. The -* j-th column of A is stored in the j-th column of the array AB -* as follows: -* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). -* -* On exit, the transformed matrix X**T*A*X, stored in the same -* format as A. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KA+1. -* -* BB (input) REAL(DOUBLE) array, dimension (LDBB,N) -* The banded factor S from the split Cholesky factorization of -* B, as returned by DPBSTF, stored in the first KB+1 rows of -* the array. -* -* LDBB (input) INTEGER -* The leading dimension of the array BB. LDBB >= KB+1. -* -* X (output) REAL(DOUBLE) array, dimension (LDX,N) -* If VECT = 'V', the n-by-n matrix X. -* If VECT = 'N', the array X is not referenced. -* -* LDX (input) INTEGER -* The leading dimension of the array X. -* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. -* -* WORK (workspace) REAL(DOUBLE) array, dimension (2*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPDATE, UPPER, WANTX - INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K, - $ KA1, KB1, KBT, L, M, NR, NRT, NX - integer loopno, phase, phase_index - REAL(DOUBLE) BII, RA, RA1, T -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - -* -* Test the input parameters -* - WANTX = LSAME( VECT, 'V' ) - UPPER = LSAME( UPLO, 'U' ) - KA1 = KA + 1 - KB1 = KB + 1 - INFO = 0 - IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( KA.LT.0 ) THEN - INFO = -4 - ELSE IF( KB.LT.0 ) THEN - INFO = -5 - ELSE IF( LDAB.LT.KA+1 ) THEN - INFO = -7 - ELSE IF( LDBB.LT.KB+1 ) THEN - INFO = -9 - ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN - INFO = -11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSBGST', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - INCA = LDAB*KA1 -* -* Initialize X to the unit matrix, if needed -* - IF( WANTX ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, X, LDX ) -* -* Set M to the splitting point m. It must be the same value as is -* used in DPBSTF. The chosen value allows the arrays WORK and RWORK -* to be of dimension (N). -* - M = ( N+KB ) / 2 -* -* The routine works in two phases, corresponding to the two halves -* of the split Cholesky factorization of B as S**T*S where -* -* S = ( U ) -* ( M L ) -* -* with U upper triangular of order m, and L lower triangular of -* order n-m. S has the same bandwidth as B. -* -* S is treated as a product of elementary matrices: -* -* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) -* -* where S(i) is determined by the i-th row of S. -* -* In phase 1, the index i takes the values n, n-1, ... , m+1; -* in phase 2, it takes the values 1, 2, ... , m. -* -* For each value of i, the current matrix A is updated by forming -* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside -* the band of A. The bulge is then pushed down toward the bottom of -* A in phase 1, and up toward the top of A in phase 2, by applying -* plane rotations. -* -* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 -* of them are linearly independent, so annihilating a bulge requires -* only 2*kb-1 plane rotations. The rotations are divided into a 1st -* set of kb-1 rotations, and a 2nd set of kb rotations. -* -* Wherever possible, rotations are generated and applied in vector -* operations of length NR between the indices J1 and J2 (sometimes -* replaced by modified values NRT, J1T or J2T). -* -* The cosines and sines of the rotations are stored in the array -* WORK. The cosines of the 1st set of rotations are stored in -* elements n+2:n+m-kb-1 and the sines of the 1st set in elements -* 2:m-kb-1; the cosines of the 2nd set are stored in elements -* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. -* -* The bulges are not formed explicitly; nonzero elements outside the -* band are created only when they are required for generating new -* rotations; they are stored in the array WORK, in positions where -* they are later overwritten by the sines of the rotations which -* annihilate them. -* -* **************************** Phase 1 ***************************** -* -* The logical structure of this phase is: -* -* UPDATE = .TRUE. -* DO I = N, M + 1, -1 -* use S(i) to update A and create a new bulge -* apply rotations to push all bulges KA positions downward -* END DO -* UPDATE = .FALSE. -* DO I = M + KA + 1, N - 1 -* apply rotations to push all bulges KA positions downward -* END DO -* -* To avoid duplicating code, the two loops are merged. -* - UPDATE = .TRUE. - I = N + 1 - write(sc1,*) - phase = 1 - phase_index = 0 - 10 CONTINUE - IF( UPDATE ) THEN - I = I - 1 - phase_index = phase_index + 1 - write(sc1,12345,advance='no') phase,phase_index,i-m,cr13_lge - KBT = MIN( KB, I-1 ) - I0 = I - 1 - I1 = MIN( N, I+KA ) - I2 = I - KBT + KA1 - IF( I.LT.M+1 ) THEN - UPDATE = .FALSE. - I = I + 1 - I0 = M - IF( KA.EQ.0 ) - $ GO TO 480 - GO TO 10 - END IF - ELSE - I = I + KA - IF( I.GT.N-1 ) - $ GO TO 480 - END IF -* - IF( UPPER ) THEN -* -* Transform A, working with the upper triangle -* - IF( UPDATE ) THEN -* -* Form inv(S(i))**T * A * inv(S(i)) -* - BII = BB( KB1, I ) - DO 20 J = I, I1 - AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII - 20 CONTINUE - DO 30 J = MAX( 1, I-KA ), I - AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII - 30 CONTINUE - DO 60 K = I - KBT, I - 1 - DO 40 J = I - KBT, K - AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - - $ BB( J-I+KB1, I )*AB( K-I+KA1, I ) - - $ BB( K-I+KB1, I )*AB( J-I+KA1, I ) + - $ AB( KA1, I )*BB( J-I+KB1, I )* - $ BB( K-I+KB1, I ) - 40 CONTINUE - DO 50 J = MAX( 1, I-KA ), I - KBT - 1 - AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - - $ BB( K-I+KB1, I )*AB( J-I+KA1, I ) - 50 CONTINUE - 60 CONTINUE - DO 80 J = I, I1 - DO 70 K = MAX( J-KA, I-KBT ), I - 1 - AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - - $ BB( K-I+KB1, I )*AB( I-J+KA1, J ) - 70 CONTINUE - 80 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by inv(S(i)) -* - CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 ) - IF( KBT.GT.0 ) - $ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1, - $ BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX ) - END IF -* -* store a(i,i1) in RA1 for use in next loop over K -* - RA1 = AB( I-I1+KA1, I1 ) - END IF -* -* Generate and apply vectors of rotations to chase all the -* existing bulges KA positions down toward the bottom of the -* band -* -! write(sc1,*) - DO 130 K = 1, KB - 1 - loopno = 130 -! write(sc1,22345,advance='no') loopno,k,kb,cr13_lge - IF( UPDATE ) THEN -* -* Determine the rotations which would annihilate the bulge -* which has in theory just been created -* - IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN -* -* generate rotation to annihilate a(i,i-k+ka+1) -* - CALL DLARTG( AB( K+1, I-K+KA ), RA1, - $ WORK( N+I-K+KA-M ), WORK( I-K+KA-M ), - $ RA ) -* -* create nonzero element a(i-k,i-k+ka+1) outside the -* band and store it in WORK(i-k) -* - T = -BB( KB1-K, I )*RA1 - WORK( I-K ) = WORK( N+I-K+KA-M )*T - - $ WORK( I-K+KA-M )*AB( 1, I-K+KA ) - AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T + - $ WORK( N+I-K+KA-M )*AB( 1, I-K+KA ) - RA1 = RA - END IF - END IF - J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 - NR = ( N-J2+KA ) / KA1 - J1 = J2 + ( NR-1 )*KA1 - IF( UPDATE ) THEN - J2T = MAX( J2, I+2*KA-K+1 ) - ELSE - J2T = J2 - END IF - NRT = ( N-J2T+KA ) / KA1 - DO 90 J = J2T, J1, KA1 -* -* create nonzero element a(j-ka,j+1) outside the band -* and store it in WORK(j-m) -* - WORK( J-M ) = WORK( J-M )*AB( 1, J+1 ) - AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 ) - 90 CONTINUE -* -* generate rotations in 1st set to annihilate elements which -* have been created outside the band -* - IF( NRT.GT.0 ) - $ CALL DLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1, - $ WORK( N+J2T-M ), KA1 ) - IF( NR.GT.0 ) THEN -* -* apply rotations in 1st set from the right -* - DO 100 L = 1, KA - 1 - CALL DLARTV( NR, AB( KA1-L, J2 ), INCA, - $ AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ), - $ WORK( J2-M ), KA1 ) - 100 CONTINUE -* -* apply rotations in 1st set from both sides to diagonal -* blocks -* - CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ), - $ AB( KA, J2+1 ), INCA, WORK( N+J2-M ), - $ WORK( J2-M ), KA1 ) -* - END IF -* -* start applying rotations in 1st set from the left -* - DO 110 L = KA - 1, KB - K + 1, -1 - NRT = ( N-J2+L ) / KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, - $ AB( L+1, J2+KA1-L ), INCA, - $ WORK( N+J2-M ), WORK( J2-M ), KA1 ) - 110 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by product of rotations in 1st set -* - DO 120 J = J2, J1, KA1 - CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, - $ WORK( N+J-M ), WORK( J-M ) ) - 120 CONTINUE - END IF - 130 CONTINUE -* - IF( UPDATE ) THEN - IF( I2.LE.N .AND. KBT.GT.0 ) THEN -* -* create nonzero element a(i-kbt,i-kbt+ka+1) outside the -* band and store it in WORK(i-kbt) -* - WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1 - END IF - END IF -* -! write(sc1,*) - DO 170 K = KB, 1, -1 - loopno = 170 -! write(sc1,22345,advance='no') loopno,k,kb,cr13_lge - IF( UPDATE ) THEN - J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1 - ELSE - J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 - END IF -* -* finish applying rotations in 2nd set from the left -* - DO 140 L = KB - K, 1, -1 - NRT = ( N-J2+KA+L ) / KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L, J2-L+1 ), INCA, - $ AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ), - $ WORK( J2-KA ), KA1 ) - 140 CONTINUE - NR = ( N-J2+KA ) / KA1 - J1 = J2 + ( NR-1 )*KA1 - DO 150 J = J1, J2, -KA1 - WORK( J ) = WORK( J-KA ) - WORK( N+J ) = WORK( N+J-KA ) - 150 CONTINUE - DO 160 J = J2, J1, KA1 -* -* create nonzero element a(j-ka,j+1) outside the band -* and store it in WORK(j) -* - WORK( J ) = WORK( J )*AB( 1, J+1 ) - AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 ) - 160 CONTINUE - IF( UPDATE ) THEN - IF( I-K.LT.N-KA .AND. K.LE.KBT ) - $ WORK( I-K+KA ) = WORK( I-K ) - END IF - 170 CONTINUE -* -! write(sc1,*) - DO 210 K = KB, 1, -1 - loopno = 210 -! write(sc1,22345,advance='no') loopno,k,kb,cr13_lge - J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 - NR = ( N-J2+KA ) / KA1 - J1 = J2 + ( NR-1 )*KA1 - IF( NR.GT.0 ) THEN -* -* generate rotations in 2nd set to annihilate elements -* which have been created outside the band -* - CALL DLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1, - $ WORK( N+J2 ), KA1 ) -* -* apply rotations in 2nd set from the right -* - DO 180 L = 1, KA - 1 - CALL DLARTV( NR, AB( KA1-L, J2 ), INCA, - $ AB( KA-L, J2+1 ), INCA, WORK( N+J2 ), - $ WORK( J2 ), KA1 ) - 180 CONTINUE -* -* apply rotations in 2nd set from both sides to diagonal -* blocks -* - CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ), - $ AB( KA, J2+1 ), INCA, WORK( N+J2 ), - $ WORK( J2 ), KA1 ) -* - END IF -* -* start applying rotations in 2nd set from the left -* - DO 190 L = KA - 1, KB - K + 1, -1 - NRT = ( N-J2+L ) / KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, - $ AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ), - $ WORK( J2 ), KA1 ) - 190 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by product of rotations in 2nd set -* - DO 200 J = J2, J1, KA1 - CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, - $ WORK( N+J ), WORK( J ) ) - 200 CONTINUE - END IF - 210 CONTINUE -* -! write(sc1,*) - DO 230 K = 1, KB - 1 - loopno = 230 -! write(sc1,22345,advance='no') loopno,k,kb,cr13_lge - J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 -* -* finish applying rotations in 1st set from the left -* - DO 220 L = KB - K, 1, -1 - NRT = ( N-J2+L ) / KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, - $ AB( L+1, J2+KA1-L ), INCA, - $ WORK( N+J2-M ), WORK( J2-M ), KA1 ) - 220 CONTINUE - 230 CONTINUE -* - IF( KB.GT.1 ) THEN - DO 240 J = N - 1, I - KB + 2*KA + 1, -1 - WORK( N+J-M ) = WORK( N+J-KA-M ) - WORK( J-M ) = WORK( J-KA-M ) - 240 CONTINUE - END IF -* - ELSE -* -* Transform A, working with the lower triangle -* - IF( UPDATE ) THEN -* -* Form inv(S(i))**T * A * inv(S(i)) -* - BII = BB( 1, I ) - DO 250 J = I, I1 - AB( J-I+1, I ) = AB( J-I+1, I ) / BII - 250 CONTINUE - DO 260 J = MAX( 1, I-KA ), I - AB( I-J+1, J ) = AB( I-J+1, J ) / BII - 260 CONTINUE - DO 290 K = I - KBT, I - 1 - DO 270 J = I - KBT, K - AB( K-J+1, J ) = AB( K-J+1, J ) - - $ BB( I-J+1, J )*AB( I-K+1, K ) - - $ BB( I-K+1, K )*AB( I-J+1, J ) + - $ AB( 1, I )*BB( I-J+1, J )* - $ BB( I-K+1, K ) - 270 CONTINUE - DO 280 J = MAX( 1, I-KA ), I - KBT - 1 - AB( K-J+1, J ) = AB( K-J+1, J ) - - $ BB( I-K+1, K )*AB( I-J+1, J ) - 280 CONTINUE - 290 CONTINUE - DO 310 J = I, I1 - DO 300 K = MAX( J-KA, I-KBT ), I - 1 - AB( J-K+1, K ) = AB( J-K+1, K ) - - $ BB( I-K+1, K )*AB( J-I+1, I ) - 300 CONTINUE - 310 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by inv(S(i)) -* - CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 ) - IF( KBT.GT.0 ) - $ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1, - $ BB( KBT+1, I-KBT ), LDBB-1, - $ X( M+1, I-KBT ), LDX ) - END IF -* -* store a(i1,i) in RA1 for use in next loop over K -* - RA1 = AB( I1-I+1, I ) - END IF -* -* Generate and apply vectors of rotations to chase all the -* existing bulges KA positions down toward the bottom of the -* band -* - DO 360 K = 1, KB - 1 - IF( UPDATE ) THEN -* -* Determine the rotations which would annihilate the bulge -* which has in theory just been created -* - IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN -* -* generate rotation to annihilate a(i-k+ka+1,i) -* - CALL DLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ), - $ WORK( I-K+KA-M ), RA ) -* -* create nonzero element a(i-k+ka+1,i-k) outside the -* band and store it in WORK(i-k) -* - T = -BB( K+1, I-K )*RA1 - WORK( I-K ) = WORK( N+I-K+KA-M )*T - - $ WORK( I-K+KA-M )*AB( KA1, I-K ) - AB( KA1, I-K ) = WORK( I-K+KA-M )*T + - $ WORK( N+I-K+KA-M )*AB( KA1, I-K ) - RA1 = RA - END IF - END IF - J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 - NR = ( N-J2+KA ) / KA1 - J1 = J2 + ( NR-1 )*KA1 - IF( UPDATE ) THEN - J2T = MAX( J2, I+2*KA-K+1 ) - ELSE - J2T = J2 - END IF - NRT = ( N-J2T+KA ) / KA1 - DO 320 J = J2T, J1, KA1 -* -* create nonzero element a(j+1,j-ka) outside the band -* and store it in WORK(j-m) -* - WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 ) - AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 ) - 320 CONTINUE -* -* generate rotations in 1st set to annihilate elements which -* have been created outside the band -* - IF( NRT.GT.0 ) - $ CALL DLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ), - $ KA1, WORK( N+J2T-M ), KA1 ) - IF( NR.GT.0 ) THEN -* -* apply rotations in 1st set from the left -* - DO 330 L = 1, KA - 1 - CALL DLARTV( NR, AB( L+1, J2-L ), INCA, - $ AB( L+2, J2-L ), INCA, WORK( N+J2-M ), - $ WORK( J2-M ), KA1 ) - 330 CONTINUE -* -* apply rotations in 1st set from both sides to diagonal -* blocks -* - CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ), - $ INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 ) -* - END IF -* -* start applying rotations in 1st set from the right -* - DO 340 L = KA - 1, KB - K + 1, -1 - NRT = ( N-J2+L ) / KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, - $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ), - $ WORK( J2-M ), KA1 ) - 340 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by product of rotations in 1st set -* - DO 350 J = J2, J1, KA1 - CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, - $ WORK( N+J-M ), WORK( J-M ) ) - 350 CONTINUE - END IF - 360 CONTINUE -* - IF( UPDATE ) THEN - IF( I2.LE.N .AND. KBT.GT.0 ) THEN -* -* create nonzero element a(i-kbt+ka+1,i-kbt) outside the -* band and store it in WORK(i-kbt) -* - WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1 - END IF - END IF -* - DO 400 K = KB, 1, -1 - IF( UPDATE ) THEN - J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1 - ELSE - J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 - END IF -* -* finish applying rotations in 2nd set from the right -* - DO 370 L = KB - K, 1, -1 - NRT = ( N-J2+KA+L ) / KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA, - $ AB( KA1-L, J2-KA+1 ), INCA, - $ WORK( N+J2-KA ), WORK( J2-KA ), KA1 ) - 370 CONTINUE - NR = ( N-J2+KA ) / KA1 - J1 = J2 + ( NR-1 )*KA1 - DO 380 J = J1, J2, -KA1 - WORK( J ) = WORK( J-KA ) - WORK( N+J ) = WORK( N+J-KA ) - 380 CONTINUE - DO 390 J = J2, J1, KA1 -* -* create nonzero element a(j+1,j-ka) outside the band -* and store it in WORK(j) -* - WORK( J ) = WORK( J )*AB( KA1, J-KA+1 ) - AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 ) - 390 CONTINUE - IF( UPDATE ) THEN - IF( I-K.LT.N-KA .AND. K.LE.KBT ) - $ WORK( I-K+KA ) = WORK( I-K ) - END IF - 400 CONTINUE -* - DO 440 K = KB, 1, -1 - J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1 - NR = ( N-J2+KA ) / KA1 - J1 = J2 + ( NR-1 )*KA1 - IF( NR.GT.0 ) THEN -* -* generate rotations in 2nd set to annihilate elements -* which have been created outside the band -* - CALL DLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1, - $ WORK( N+J2 ), KA1 ) -* -* apply rotations in 2nd set from the left -* - DO 410 L = 1, KA - 1 - CALL DLARTV( NR, AB( L+1, J2-L ), INCA, - $ AB( L+2, J2-L ), INCA, WORK( N+J2 ), - $ WORK( J2 ), KA1 ) - 410 CONTINUE -* -* apply rotations in 2nd set from both sides to diagonal -* blocks -* - CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ), - $ INCA, WORK( N+J2 ), WORK( J2 ), KA1 ) -* - END IF -* -* start applying rotations in 2nd set from the right -* - DO 420 L = KA - 1, KB - K + 1, -1 - NRT = ( N-J2+L ) / KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, - $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ), - $ WORK( J2 ), KA1 ) - 420 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by product of rotations in 2nd set -* - DO 430 J = J2, J1, KA1 - CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, - $ WORK( N+J ), WORK( J ) ) - 430 CONTINUE - END IF - 440 CONTINUE -* - DO 460 K = 1, KB - 1 - J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1 -* -* finish applying rotations in 1st set from the right -* - DO 450 L = KB - K, 1, -1 - NRT = ( N-J2+L ) / KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, - $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ), - $ WORK( J2-M ), KA1 ) - 450 CONTINUE - 460 CONTINUE -* - IF( KB.GT.1 ) THEN - DO 470 J = N - 1, I - KB + 2*KA + 1, -1 - WORK( N+J-M ) = WORK( N+J-KA-M ) - WORK( J-M ) = WORK( J-KA-M ) - 470 CONTINUE - END IF -* - END IF -* - GO TO 10 -* - 480 CONTINUE -* -* **************************** Phase 2 ***************************** -* -* The logical structure of this phase is: -* -* UPDATE = .TRUE. -* DO I = 1, M -* use S(i) to update A and create a new bulge -* apply rotations to push all bulges KA positions upward -* END DO -* UPDATE = .FALSE. -* DO I = M - KA - 1, 2, -1 -* apply rotations to push all bulges KA positions upward -* END DO -* -* To avoid duplicating code, the two loops are merged. -* - UPDATE = .TRUE. - I = 0 - write(sc1,*) - phase = 1 - 490 CONTINUE - IF( UPDATE ) THEN - write(sc1,12345,advance='no') phase,i,m,cr13_lge - I = I + 1 - KBT = MIN( KB, M-I ) - I0 = I + 1 - I1 = MAX( 1, I-KA ) - I2 = I + KBT - KA1 - IF( I.GT.M ) THEN - UPDATE = .FALSE. - I = I - 1 - I0 = M + 1 - IF( KA.EQ.0 ) - $ RETURN - GO TO 490 - END IF - ELSE - I = I - KA - IF( I.LT.2 ) - $ RETURN - END IF -* - IF( I.LT.M-KBT ) THEN - NX = M - ELSE - NX = N - END IF -* - IF( UPPER ) THEN -* -* Transform A, working with the upper triangle -* - IF( UPDATE ) THEN -* -* Form inv(S(i))**T * A * inv(S(i)) -* - BII = BB( KB1, I ) - DO 500 J = I1, I - AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII - 500 CONTINUE - DO 510 J = I, MIN( N, I+KA ) - AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII - 510 CONTINUE - DO 540 K = I + 1, I + KBT - DO 520 J = K, I + KBT - AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - - $ BB( I-J+KB1, J )*AB( I-K+KA1, K ) - - $ BB( I-K+KB1, K )*AB( I-J+KA1, J ) + - $ AB( KA1, I )*BB( I-J+KB1, J )* - $ BB( I-K+KB1, K ) - 520 CONTINUE - DO 530 J = I + KBT + 1, MIN( N, I+KA ) - AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - - $ BB( I-K+KB1, K )*AB( I-J+KA1, J ) - 530 CONTINUE - 540 CONTINUE - DO 560 J = I1, I - DO 550 K = I + 1, MIN( J+KA, I+KBT ) - AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - - $ BB( I-K+KB1, K )*AB( J-I+KA1, I ) - 550 CONTINUE - 560 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by inv(S(i)) -* - CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 ) - IF( KBT.GT.0 ) - $ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ), - $ LDBB-1, X( 1, I+1 ), LDX ) - END IF -* -* store a(i1,i) in RA1 for use in next loop over K -* - RA1 = AB( I1-I+KA1, I ) - END IF -* -* Generate and apply vectors of rotations to chase all the -* existing bulges KA positions up toward the top of the band -* -! write(sc1,*) - DO 610 K = 1, KB - 1 - loopno = 610 -! write(sc1,22345,advance='no') loopno,k,kb,cr13_lge - IF( UPDATE ) THEN -* -* Determine the rotations which would annihilate the bulge -* which has in theory just been created -* - IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN -* -* generate rotation to annihilate a(i+k-ka-1,i) -* - CALL DLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ), - $ WORK( I+K-KA ), RA ) -* -* create nonzero element a(i+k-ka-1,i+k) outside the -* band and store it in WORK(m-kb+i+k) -* - T = -BB( KB1-K, I+K )*RA1 - WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T - - $ WORK( I+K-KA )*AB( 1, I+K ) - AB( 1, I+K ) = WORK( I+K-KA )*T + - $ WORK( N+I+K-KA )*AB( 1, I+K ) - RA1 = RA - END IF - END IF - J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 - NR = ( J2+KA-1 ) / KA1 - J1 = J2 - ( NR-1 )*KA1 - IF( UPDATE ) THEN - J2T = MIN( J2, I-2*KA+K-1 ) - ELSE - J2T = J2 - END IF - NRT = ( J2T+KA-1 ) / KA1 - DO 570 J = J1, J2T, KA1 -* -* create nonzero element a(j-1,j+ka) outside the band -* and store it in WORK(j) -* - WORK( J ) = WORK( J )*AB( 1, J+KA-1 ) - AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 ) - 570 CONTINUE -* -* generate rotations in 1st set to annihilate elements which -* have been created outside the band -* - IF( NRT.GT.0 ) - $ CALL DLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1, - $ WORK( N+J1 ), KA1 ) - IF( NR.GT.0 ) THEN -* -* apply rotations in 1st set from the left -* - DO 580 L = 1, KA - 1 - CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA, - $ AB( KA-L, J1+L ), INCA, WORK( N+J1 ), - $ WORK( J1 ), KA1 ) - 580 CONTINUE -* -* apply rotations in 1st set from both sides to diagonal -* blocks -* - CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ), - $ AB( KA, J1 ), INCA, WORK( N+J1 ), - $ WORK( J1 ), KA1 ) -* - END IF -* -* start applying rotations in 1st set from the right -* - DO 590 L = KA - 1, KB - K + 1, -1 - NRT = ( J2+L-1 ) / KA1 - J1T = J2 - ( NRT-1 )*KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L, J1T ), INCA, - $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ), - $ WORK( J1T ), KA1 ) - 590 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by product of rotations in 1st set -* - DO 600 J = J1, J2, KA1 - CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, - $ WORK( N+J ), WORK( J ) ) - 600 CONTINUE - END IF - 610 CONTINUE -* - IF( UPDATE ) THEN - IF( I2.GT.0 .AND. KBT.GT.0 ) THEN -* -* create nonzero element a(i+kbt-ka-1,i+kbt) outside the -* band and store it in WORK(m-kb+i+kbt) -* - WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1 - END IF - END IF -* -! write(sc1,*) - DO 650 K = KB, 1, -1 - loopno = 650 -! write(sc1,22345,advance='no') loopno,k,kb,cr13_lge - IF( UPDATE ) THEN - J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1 - ELSE - J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 - END IF -* -* finish applying rotations in 2nd set from the right -* - DO 620 L = KB - K, 1, -1 - NRT = ( J2+KA+L-1 ) / KA1 - J1T = J2 - ( NRT-1 )*KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L, J1T+KA ), INCA, - $ AB( L+1, J1T+KA-1 ), INCA, - $ WORK( N+M-KB+J1T+KA ), - $ WORK( M-KB+J1T+KA ), KA1 ) - 620 CONTINUE - NR = ( J2+KA-1 ) / KA1 - J1 = J2 - ( NR-1 )*KA1 - DO 630 J = J1, J2, KA1 - WORK( M-KB+J ) = WORK( M-KB+J+KA ) - WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA ) - 630 CONTINUE - DO 640 J = J1, J2, KA1 -* -* create nonzero element a(j-1,j+ka) outside the band -* and store it in WORK(m-kb+j) -* - WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 ) - AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 ) - 640 CONTINUE - IF( UPDATE ) THEN - IF( I+K.GT.KA1 .AND. K.LE.KBT ) - $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K ) - END IF - 650 CONTINUE -* -! write(sc1,*) - DO 690 K = KB, 1, -1 - loopno = 690 -! write(sc1,22345,advance='no') loopno,k,kb,cr13_lge - J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 - NR = ( J2+KA-1 ) / KA1 - J1 = J2 - ( NR-1 )*KA1 - IF( NR.GT.0 ) THEN -* -* generate rotations in 2nd set to annihilate elements -* which have been created outside the band -* - CALL DLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ), - $ KA1, WORK( N+M-KB+J1 ), KA1 ) -* -* apply rotations in 2nd set from the left -* - DO 660 L = 1, KA - 1 - CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA, - $ AB( KA-L, J1+L ), INCA, - $ WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 ) - 660 CONTINUE -* -* apply rotations in 2nd set from both sides to diagonal -* blocks -* - CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ), - $ AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ), - $ WORK( M-KB+J1 ), KA1 ) -* - END IF -* -* start applying rotations in 2nd set from the right -* - DO 670 L = KA - 1, KB - K + 1, -1 - NRT = ( J2+L-1 ) / KA1 - J1T = J2 - ( NRT-1 )*KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L, J1T ), INCA, - $ AB( L+1, J1T-1 ), INCA, - $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ), - $ KA1 ) - 670 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by product of rotations in 2nd set -* - DO 680 J = J1, J2, KA1 - CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, - $ WORK( N+M-KB+J ), WORK( M-KB+J ) ) - 680 CONTINUE - END IF - 690 CONTINUE -* -! write(sc1,*) - DO 710 K = 1, KB - 1 - loopno = 710 -! write(sc1,22345,advance='no') loopno,k,kb,cr13_lge - J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 -* -* finish applying rotations in 1st set from the right -* - DO 700 L = KB - K, 1, -1 - NRT = ( J2+L-1 ) / KA1 - J1T = J2 - ( NRT-1 )*KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L, J1T ), INCA, - $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ), - $ WORK( J1T ), KA1 ) - 700 CONTINUE - 710 CONTINUE -* - IF( KB.GT.1 ) THEN - DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1 - WORK( N+J ) = WORK( N+J+KA ) - WORK( J ) = WORK( J+KA ) - 720 CONTINUE - END IF -* - ELSE -* -* Transform A, working with the lower triangle -* - IF( UPDATE ) THEN -* -* Form inv(S(i))**T * A * inv(S(i)) -* - BII = BB( 1, I ) - DO 730 J = I1, I - AB( I-J+1, J ) = AB( I-J+1, J ) / BII - 730 CONTINUE - DO 740 J = I, MIN( N, I+KA ) - AB( J-I+1, I ) = AB( J-I+1, I ) / BII - 740 CONTINUE - DO 770 K = I + 1, I + KBT - DO 750 J = K, I + KBT - AB( J-K+1, K ) = AB( J-K+1, K ) - - $ BB( J-I+1, I )*AB( K-I+1, I ) - - $ BB( K-I+1, I )*AB( J-I+1, I ) + - $ AB( 1, I )*BB( J-I+1, I )* - $ BB( K-I+1, I ) - 750 CONTINUE - DO 760 J = I + KBT + 1, MIN( N, I+KA ) - AB( J-K+1, K ) = AB( J-K+1, K ) - - $ BB( K-I+1, I )*AB( J-I+1, I ) - 760 CONTINUE - 770 CONTINUE - DO 790 J = I1, I - DO 780 K = I + 1, MIN( J+KA, I+KBT ) - AB( K-J+1, J ) = AB( K-J+1, J ) - - $ BB( K-I+1, I )*AB( I-J+1, J ) - 780 CONTINUE - 790 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by inv(S(i)) -* - CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 ) - IF( KBT.GT.0 ) - $ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1, - $ X( 1, I+1 ), LDX ) - END IF -* -* store a(i,i1) in RA1 for use in next loop over K -* - RA1 = AB( I-I1+1, I1 ) - END IF -* -* Generate and apply vectors of rotations to chase all the -* existing bulges KA positions up toward the top of the band -* - DO 840 K = 1, KB - 1 - IF( UPDATE ) THEN -* -* Determine the rotations which would annihilate the bulge -* which has in theory just been created -* - IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN -* -* generate rotation to annihilate a(i,i+k-ka-1) -* - CALL DLARTG( AB( KA1-K, I+K-KA ), RA1, - $ WORK( N+I+K-KA ), WORK( I+K-KA ), RA ) -* -* create nonzero element a(i+k,i+k-ka-1) outside the -* band and store it in WORK(m-kb+i+k) -* - T = -BB( K+1, I )*RA1 - WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T - - $ WORK( I+K-KA )*AB( KA1, I+K-KA ) - AB( KA1, I+K-KA ) = WORK( I+K-KA )*T + - $ WORK( N+I+K-KA )*AB( KA1, I+K-KA ) - RA1 = RA - END IF - END IF - J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 - NR = ( J2+KA-1 ) / KA1 - J1 = J2 - ( NR-1 )*KA1 - IF( UPDATE ) THEN - J2T = MIN( J2, I-2*KA+K-1 ) - ELSE - J2T = J2 - END IF - NRT = ( J2T+KA-1 ) / KA1 - DO 800 J = J1, J2T, KA1 -* -* create nonzero element a(j+ka,j-1) outside the band -* and store it in WORK(j) -* - WORK( J ) = WORK( J )*AB( KA1, J-1 ) - AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 ) - 800 CONTINUE -* -* generate rotations in 1st set to annihilate elements which -* have been created outside the band -* - IF( NRT.GT.0 ) - $ CALL DLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1, - $ WORK( N+J1 ), KA1 ) - IF( NR.GT.0 ) THEN -* -* apply rotations in 1st set from the right -* - DO 810 L = 1, KA - 1 - CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ), - $ INCA, WORK( N+J1 ), WORK( J1 ), KA1 ) - 810 CONTINUE -* -* apply rotations in 1st set from both sides to diagonal -* blocks -* - CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ), - $ AB( 2, J1-1 ), INCA, WORK( N+J1 ), - $ WORK( J1 ), KA1 ) -* - END IF -* -* start applying rotations in 1st set from the left -* - DO 820 L = KA - 1, KB - K + 1, -1 - NRT = ( J2+L-1 ) / KA1 - J1T = J2 - ( NRT-1 )*KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, - $ AB( KA1-L, J1T-KA1+L ), INCA, - $ WORK( N+J1T ), WORK( J1T ), KA1 ) - 820 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by product of rotations in 1st set -* - DO 830 J = J1, J2, KA1 - CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, - $ WORK( N+J ), WORK( J ) ) - 830 CONTINUE - END IF - 840 CONTINUE -* - IF( UPDATE ) THEN - IF( I2.GT.0 .AND. KBT.GT.0 ) THEN -* -* create nonzero element a(i+kbt,i+kbt-ka-1) outside the -* band and store it in WORK(m-kb+i+kbt) -* - WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1 - END IF - END IF -* - DO 880 K = KB, 1, -1 - IF( UPDATE ) THEN - J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1 - ELSE - J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 - END IF -* -* finish applying rotations in 2nd set from the left -* - DO 850 L = KB - K, 1, -1 - NRT = ( J2+KA+L-1 ) / KA1 - J1T = J2 - ( NRT-1 )*KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA, - $ AB( KA1-L, J1T+L-1 ), INCA, - $ WORK( N+M-KB+J1T+KA ), - $ WORK( M-KB+J1T+KA ), KA1 ) - 850 CONTINUE - NR = ( J2+KA-1 ) / KA1 - J1 = J2 - ( NR-1 )*KA1 - DO 860 J = J1, J2, KA1 - WORK( M-KB+J ) = WORK( M-KB+J+KA ) - WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA ) - 860 CONTINUE - DO 870 J = J1, J2, KA1 -* -* create nonzero element a(j+ka,j-1) outside the band -* and store it in WORK(m-kb+j) -* - WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 ) - AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 ) - 870 CONTINUE - IF( UPDATE ) THEN - IF( I+K.GT.KA1 .AND. K.LE.KBT ) - $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K ) - END IF - 880 CONTINUE -* - DO 920 K = KB, 1, -1 - J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1 - NR = ( J2+KA-1 ) / KA1 - J1 = J2 - ( NR-1 )*KA1 - IF( NR.GT.0 ) THEN -* -* generate rotations in 2nd set to annihilate elements -* which have been created outside the band -* - CALL DLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ), - $ KA1, WORK( N+M-KB+J1 ), KA1 ) -* -* apply rotations in 2nd set from the right -* - DO 890 L = 1, KA - 1 - CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ), - $ INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), - $ KA1 ) - 890 CONTINUE -* -* apply rotations in 2nd set from both sides to diagonal -* blocks -* - CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ), - $ AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ), - $ WORK( M-KB+J1 ), KA1 ) -* - END IF -* -* start applying rotations in 2nd set from the left -* - DO 900 L = KA - 1, KB - K + 1, -1 - NRT = ( J2+L-1 ) / KA1 - J1T = J2 - ( NRT-1 )*KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, - $ AB( KA1-L, J1T-KA1+L ), INCA, - $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ), - $ KA1 ) - 900 CONTINUE -* - IF( WANTX ) THEN -* -* post-multiply X by product of rotations in 2nd set -* - DO 910 J = J1, J2, KA1 - CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, - $ WORK( N+M-KB+J ), WORK( M-KB+J ) ) - 910 CONTINUE - END IF - 920 CONTINUE -* - DO 940 K = 1, KB - 1 - J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1 -* -* finish applying rotations in 1st set from the left -* - DO 930 L = KB - K, 1, -1 - NRT = ( J2+L-1 ) / KA1 - J1T = J2 - ( NRT-1 )*KA1 - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, - $ AB( KA1-L, J1T-KA1+L ), INCA, - $ WORK( N+J1T ), WORK( J1T ), KA1 ) - 930 CONTINUE - 940 CONTINUE -* - IF( KB.GT.1 ) THEN - DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1 - WORK( N+J ) = WORK( N+J+KA ) - WORK( J ) = WORK( J+KA ) - 950 CONTINUE - END IF -* - END IF -* - GO TO 490 - - - RETURN -* -* End of DSBGST - -! ********************************************************************************************************************************** -22345 format(5X,'Loop ',i8,': K = ',i8,' of ',i8, a) - -12345 format(5X,'Phase ',i1,': Updating from index ',i8,' to ',i8, a) - -! ********************************************************************************************************************************** - - END SUBROUTINE DSBGST - -! ################################################################################################################################## -! 005 LAPACK_GIV_MGIV_EIG - - SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, - $ WORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSBTRD' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER UPLO, VECT - INTEGER INFO, KD, LDAB, LDQ, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), - $ WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSBTRD reduces a real symmetric band matrix A to symmetric -* tridiagonal form T by an orthogonal similarity transformation: -* Q**T * A * Q = T. -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* = 'N': do not form Q; -* = 'V': form Q; -* = 'U': update a matrix X, by forming X*Q. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of superdiagonals of the matrix A if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KD >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB,N) -* On entry, the upper or lower triangle of the symmetric band -* matrix A, stored in the first KD+1 rows of the array. The -* j-th column of A is stored in the j-th column of the array AB -* as follows: -* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -* On exit, the diagonal elements of AB are overwritten by the -* diagonal elements of the tridiagonal matrix T; if KD > 0, the -* elements on the first superdiagonal (if UPLO = 'U') or the -* first subdiagonal (if UPLO = 'L') are overwritten by the -* off-diagonal elements of T; the rest of AB is overwritten by -* values generated during the reduction. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* D (output) REAL(DOUBLE) array, dimension (N) -* The diagonal elements of the tridiagonal matrix T. -* -* E (output) REAL(DOUBLE) array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix T: -* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. -* -* Q (input/output) REAL(DOUBLE) array, dimension (LDQ,N) -* On entry, if VECT = 'U', then Q must contain an N-by-N -* matrix X; if VECT = 'N' or 'V', then Q need not be set. -* -* On exit: -* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; -* if VECT = 'U', Q contains the product X*Q; -* if VECT = 'N', the array Q is not referenced. -* -* LDQ (input) INTEGER -* The leading dimension of the array Q. -* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. -* -* WORK (workspace) REAL(DOUBLE) array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* Modified by Linda Kaufman, Bell Labs. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL INITQ, UPPER, WANTQ - INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J, - $ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1, - $ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT - REAL(DOUBLE) TEMP -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. - -* -* Test the input parameters -* - INITQ = LSAME( VECT, 'V' ) - WANTQ = INITQ .OR. LSAME( VECT, 'U' ) - UPPER = LSAME( UPLO, 'U' ) - KD1 = KD + 1 - KDM1 = KD - 1 - INCX = LDAB - 1 - IQEND = 1 -* - INFO = 0 - IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( KD.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KD1 ) THEN - INFO = -6 - ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSBTRD', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Initialize Q to the unit matrix, if needed -* - IF( INITQ ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) -* -* Wherever possible, plane rotations are generated and applied in -* vector operations of length NR over the index set J1:J2:KD1. -* -* The cosines and sines of the plane rotations are stored in the -* arrays D and WORK. -* - INCA = KD1*LDAB - KDN = MIN( N-1, KD ) - IF( UPPER ) THEN -* - IF( KD.GT.1 ) THEN -* -* Reduce to tridiagonal form, working with upper triangle -* - NR = 0 - J1 = KDN + 2 - J2 = 1 -* - write(sc1,*) - DO 90 I = 1, N - 2 - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') i,n-2,cr13_lge - ENDIF -* -* Reduce i-th row of matrix to tridiagonal form -* - DO 80 K = KDN + 1, 2, -1 - J1 = J1 + KDN - J2 = J2 + KDN -* - IF( NR.GT.0 ) THEN -* -* generate plane rotations to annihilate nonzero -* elements which have been created outside the band -* - CALL DLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ), - $ KD1, D( J1 ), KD1 ) -* -* apply rotations from the right -* -* -* Dependent on the the number of diagonals either -* DLARTV or DROT is used -* - IF( NR.GE.2*KD-1 ) THEN - DO 10 L = 1, KD - 1 - CALL DLARTV( NR, AB( L+1, J1-1 ), INCA, - $ AB( L, J1 ), INCA, D( J1 ), - $ WORK( J1 ), KD1 ) - 10 CONTINUE -* - ELSE - JEND = J1 + ( NR-1 )*KD1 - DO 20 JINC = J1, JEND, KD1 - CALL DROT( KDM1, AB( 2, JINC-1 ), 1, - $ AB( 1, JINC ), 1, D( JINC ), - $ WORK( JINC ) ) - 20 CONTINUE - END IF - END IF -* -* - IF( K.GT.2 ) THEN - IF( K.LE.N-I+1 ) THEN -* -* generate plane rotation to annihilate a(i,i+k-1) -* within the band -* - CALL DLARTG( AB( KD-K+3, I+K-2 ), - $ AB( KD-K+2, I+K-1 ), D( I+K-1 ), - $ WORK( I+K-1 ), TEMP ) - AB( KD-K+3, I+K-2 ) = TEMP -* -* apply rotation from the right -* - CALL DROT( K-3, AB( KD-K+4, I+K-2 ), 1, - $ AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ), - $ WORK( I+K-1 ) ) - END IF - NR = NR + 1 - J1 = J1 - KDN - 1 - END IF -* -* apply plane rotations from both sides to diagonal -* blocks -* - IF( NR.GT.0 ) - $ CALL DLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ), - $ AB( KD, J1 ), INCA, D( J1 ), - $ WORK( J1 ), KD1 ) -* -* apply plane rotations from the left -* - IF( NR.GT.0 ) THEN - IF( 2*KD-1.LT.NR ) THEN -* -* Dependent on the the number of diagonals either -* DLARTV or DROT is used -* - DO 30 L = 1, KD - 1 - IF( J2+L.GT.N ) THEN - NRT = NR - 1 - ELSE - NRT = NR - END IF - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( KD-L, J1+L ), INCA, - $ AB( KD-L+1, J1+L ), INCA, - $ D( J1 ), WORK( J1 ), KD1 ) - 30 CONTINUE - ELSE - J1END = J1 + KD1*( NR-2 ) - IF( J1END.GE.J1 ) THEN - DO 40 JIN = J1, J1END, KD1 - CALL DROT( KD-1, AB( KD-1, JIN+1 ), INCX, - $ AB( KD, JIN+1 ), INCX, - $ D( JIN ), WORK( JIN ) ) - 40 CONTINUE - END IF - LEND = MIN( KDM1, N-J2 ) - LAST = J1END + KD1 - IF( LEND.GT.0 ) - $ CALL DROT( LEND, AB( KD-1, LAST+1 ), INCX, - $ AB( KD, LAST+1 ), INCX, D( LAST ), - $ WORK( LAST ) ) - END IF - END IF -* - IF( WANTQ ) THEN -* -* accumulate product of plane rotations in Q -* - IF( INITQ ) THEN -* -* take advantage of the fact that Q was -* initially the Identity matrix -* - IQEND = MAX( IQEND, J2 ) - I2 = MAX( 0, K-3 ) - IQAEND = 1 + I*KD - IF( K.EQ.2 ) - $ IQAEND = IQAEND + KD - IQAEND = MIN( IQAEND, IQEND ) - DO 50 J = J1, J2, KD1 - IBL = I - I2 / KDM1 - I2 = I2 + 1 - IQB = MAX( 1, J-IBL ) - NQ = 1 + IQAEND - IQB - IQAEND = MIN( IQAEND+KD, IQEND ) - CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ), - $ 1, D( J ), WORK( J ) ) - 50 CONTINUE - ELSE -* - DO 60 J = J1, J2, KD1 - CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1, - $ D( J ), WORK( J ) ) - 60 CONTINUE - END IF -* - END IF -* - IF( J2+KDN.GT.N ) THEN -* -* adjust J2 to keep within the bounds of the matrix -* - NR = NR - 1 - J2 = J2 - KDN - 1 - END IF -* - DO 70 J = J1, J2, KD1 -* -* create nonzero element a(j-1,j+kd) outside the band -* and store it in WORK -* - WORK( J+KD ) = WORK( J )*AB( 1, J+KD ) - AB( 1, J+KD ) = D( J )*AB( 1, J+KD ) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - END IF -* - IF( KD.GT.0 ) THEN -* -* copy off-diagonal elements to E -* - DO 100 I = 1, N - 1 - E( I ) = AB( KD, I+1 ) - 100 CONTINUE - ELSE -* -* set E to zero if original matrix was diagonal -* - DO 110 I = 1, N - 1 - E( I ) = ZERO - 110 CONTINUE - END IF -* -* copy diagonal elements to D -* - DO 120 I = 1, N - D( I ) = AB( KD1, I ) - 120 CONTINUE -* - ELSE -* - IF( KD.GT.1 ) THEN -* -* Reduce to tridiagonal form, working with lower triangle -* - NR = 0 - J1 = KDN + 2 - J2 = 1 -* - DO 210 I = 1, N - 2 -* -* Reduce i-th column of matrix to tridiagonal form -* - DO 200 K = KDN + 1, 2, -1 - J1 = J1 + KDN - J2 = J2 + KDN -* - IF( NR.GT.0 ) THEN -* -* generate plane rotations to annihilate nonzero -* elements which have been created outside the band -* - CALL DLARGV( NR, AB( KD1, J1-KD1 ), INCA, - $ WORK( J1 ), KD1, D( J1 ), KD1 ) -* -* apply plane rotations from one side -* -* -* Dependent on the the number of diagonals either -* DLARTV or DROT is used -* - IF( NR.GT.2*KD-1 ) THEN - DO 130 L = 1, KD - 1 - CALL DLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA, - $ AB( KD1-L+1, J1-KD1+L ), INCA, - $ D( J1 ), WORK( J1 ), KD1 ) - 130 CONTINUE - ELSE - JEND = J1 + KD1*( NR-1 ) - DO 140 JINC = J1, JEND, KD1 - CALL DROT( KDM1, AB( KD, JINC-KD ), INCX, - $ AB( KD1, JINC-KD ), INCX, - $ D( JINC ), WORK( JINC ) ) - 140 CONTINUE - END IF -* - END IF -* - IF( K.GT.2 ) THEN - IF( K.LE.N-I+1 ) THEN -* -* generate plane rotation to annihilate a(i+k-1,i) -* within the band -* - CALL DLARTG( AB( K-1, I ), AB( K, I ), - $ D( I+K-1 ), WORK( I+K-1 ), TEMP ) - AB( K-1, I ) = TEMP -* -* apply rotation from the left -* - CALL DROT( K-3, AB( K-2, I+1 ), LDAB-1, - $ AB( K-1, I+1 ), LDAB-1, D( I+K-1 ), - $ WORK( I+K-1 ) ) - END IF - NR = NR + 1 - J1 = J1 - KDN - 1 - END IF -* -* apply plane rotations from both sides to diagonal -* blocks -* - IF( NR.GT.0 ) - $ CALL DLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ), - $ AB( 2, J1-1 ), INCA, D( J1 ), - $ WORK( J1 ), KD1 ) -* -* apply plane rotations from the right -* -* -* Dependent on the the number of diagonals either -* DLARTV or DROT is used -* - IF( NR.GT.0 ) THEN - IF( NR.GT.2*KD-1 ) THEN - DO 150 L = 1, KD - 1 - IF( J2+L.GT.N ) THEN - NRT = NR - 1 - ELSE - NRT = NR - END IF - IF( NRT.GT.0 ) - $ CALL DLARTV( NRT, AB( L+2, J1-1 ), INCA, - $ AB( L+1, J1 ), INCA, D( J1 ), - $ WORK( J1 ), KD1 ) - 150 CONTINUE - ELSE - J1END = J1 + KD1*( NR-2 ) - IF( J1END.GE.J1 ) THEN - DO 160 J1INC = J1, J1END, KD1 - CALL DROT( KDM1, AB( 3, J1INC-1 ), 1, - $ AB( 2, J1INC ), 1, D( J1INC ), - $ WORK( J1INC ) ) - 160 CONTINUE - END IF - LEND = MIN( KDM1, N-J2 ) - LAST = J1END + KD1 - IF( LEND.GT.0 ) - $ CALL DROT( LEND, AB( 3, LAST-1 ), 1, - $ AB( 2, LAST ), 1, D( LAST ), - $ WORK( LAST ) ) - END IF - END IF -* -* -* - IF( WANTQ ) THEN -* -* accumulate product of plane rotations in Q -* - IF( INITQ ) THEN -* -* take advantage of the fact that Q was -* initially the Identity matrix -* - IQEND = MAX( IQEND, J2 ) - I2 = MAX( 0, K-3 ) - IQAEND = 1 + I*KD - IF( K.EQ.2 ) - $ IQAEND = IQAEND + KD - IQAEND = MIN( IQAEND, IQEND ) - DO 170 J = J1, J2, KD1 - IBL = I - I2 / KDM1 - I2 = I2 + 1 - IQB = MAX( 1, J-IBL ) - NQ = 1 + IQAEND - IQB - IQAEND = MIN( IQAEND+KD, IQEND ) - CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ), - $ 1, D( J ), WORK( J ) ) - 170 CONTINUE - ELSE -* - DO 180 J = J1, J2, KD1 - CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1, - $ D( J ), WORK( J ) ) - 180 CONTINUE - END IF - END IF -* - IF( J2+KDN.GT.N ) THEN -* -* adjust J2 to keep within the bounds of the matrix -* - NR = NR - 1 - J2 = J2 - KDN - 1 - END IF -* - DO 190 J = J1, J2, KD1 -* -* create nonzero element a(j+kd,j-1) outside the -* band and store it in WORK -* - WORK( J+KD ) = WORK( J )*AB( KD1, J ) - AB( KD1, J ) = D( J )*AB( KD1, J ) - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE - END IF -* - IF( KD.GT.0 ) THEN -* -* copy off-diagonal elements to E -* - DO 220 I = 1, N - 1 - E( I ) = AB( 2, I ) - 220 CONTINUE - ELSE -* -* set E to zero if original matrix was diagonal -* - DO 230 I = 1, N - 1 - E( I ) = ZERO - 230 CONTINUE - END IF -* -* copy diagonal elements to D -* - DO 240 I = 1, N - D( I ) = AB( 1, I ) - 240 CONTINUE - END IF -* - - RETURN -* -* End of DSBTRD -* -! ********************************************************************************************************************************** -12345 format(5X,'Loop ',i8,' of ',i8, a) - -! ********************************************************************************************************************************** - - END SUBROUTINE DSBTRD - -! ################################################################################################################################## -! 006 LAPACK_GIV_MGIV_EIG - - SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, - $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, - $ INFO, lowest_mode_num, highest_mode_num ) - -! /////////////////////////////////////////////////////////////////////B - use pentium_ii_kind - - use outa_here_interface - - character(len=len(blnk_sub_nam)):: subr_name = 'DSTEBZ' -! /////////////////////////////////////////////////////////////////////E -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER ORDER, RANGE - INTEGER IL, INFO, IU, M, N, NSPLIT - integer lowest_mode_num, highest_mode_num - REAL(DOUBLE) ABSTOL, VL, VU -* .. -* .. Array Arguments .. - INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) - REAL(DOUBLE) D( * ), E( * ), W( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSTEBZ computes the eigenvalues of a symmetric tridiagonal -* matrix T. The user may ask for all eigenvalues, all eigenvalues -* in the half-open interval (VL, VU], or the IL-th through IU-th -* eigenvalues. -* -* To avoid overflow, the matrix must be scaled so that its -* largest element is no greater than overflow**(1/2) * -* underflow**(1/4) in absolute value, and for greatest -* accuracy, it should not be much smaller than that. -* -* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal -* Matrix", Report CS41, Computer Science Dept., Stanford -* University, July 21, 1966. -* -* Arguments -* ========= -* -* RANGE (input) CHARACTER -* = 'A': ("All") all eigenvalues will be found. -* = 'V': ("Value") all eigenvalues in the half-open interval -* (VL, VU] will be found. -* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the -* entire matrix) will be found. -* -* ORDER (input) CHARACTER -* = 'B': ("By Block") the eigenvalues will be grouped by -* split-off block (see IBLOCK, ISPLIT) and -* ordered from smallest to largest within -* the block. -* = 'E': ("Entire matrix") -* the eigenvalues for the entire matrix -* will be ordered from smallest to -* largest. -* -* N (input) INTEGER -* The order of the tridiagonal matrix T. N >= 0. -* -* VL (input) REAL(DOUBLE) -* VU (input) REAL(DOUBLE) -* If RANGE='V', the lower and upper bounds of the interval to -* be searched for eigenvalues. Eigenvalues less than or equal -* to VL, or greater than VU, will not be returned. VL < VU. -* Not referenced if RANGE = 'A' or 'I'. -* -* IL (input) INTEGER -* IU (input) INTEGER -* If RANGE='I', the indices (in ascending order) of the -* smallest and largest eigenvalues to be returned. -* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. -* Not referenced if RANGE = 'A' or 'V'. -* -* ABSTOL (input) REAL(DOUBLE) -* The absolute tolerance for the eigenvalues. An eigenvalue -* (or cluster) is considered to be located if it has been -* determined to lie in an interval whose width is ABSTOL or -* less. If ABSTOL is less than or equal to zero, then ULP*|T| -* will be used, where |T| means the 1-norm of T. -* -* Eigenvalues will be computed most accurately when ABSTOL is -* set to twice the underflow threshold 2*DLAMCH('S'), not zero. -* -* D (input) REAL(DOUBLE) array, dimension (N) -* The n diagonal elements of the tridiagonal matrix T. -* -* E (input) REAL(DOUBLE) array, dimension (N-1) -* The (n-1) off-diagonal elements of the tridiagonal matrix T. -* -* M (output) INTEGER -* The actual number of eigenvalues found. 0 <= M <= N. -* (See also the description of INFO=2,3.) -* -* NSPLIT (output) INTEGER -* The number of diagonal blocks in the matrix T. -* 1 <= NSPLIT <= N. -* -* W (output) REAL(DOUBLE) array, dimension (N) -* On exit, the first M elements of W will contain the -* eigenvalues. (DSTEBZ may use the remaining N-M elements as -* workspace.) -* -* IBLOCK (output) INTEGER array, dimension (N) -* At each row/column j where E(j) is zero or small, the -* matrix T is considered to split into a block diagonal -* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which -* block (from 1 to the number of blocks) the eigenvalue W(i) -* belongs. (DSTEBZ may use the remaining N-M elements as -* workspace.) -* -* ISPLIT (output) INTEGER array, dimension (N) -* The splitting points, at which T breaks up into submatrices. -* The first submatrix consists of rows/columns 1 to ISPLIT(1), -* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), -* etc., and the NSPLIT-th consists of rows/columns -* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. -* (Only the first NSPLIT elements will actually be used, but -* since the user cannot know a priori what value NSPLIT will -* have, N words must be reserved for ISPLIT.) -* -* WORK (workspace) REAL(DOUBLE) array, dimension (4*N) -* -* IWORK (workspace) INTEGER array, dimension (3*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: some or all of the eigenvalues failed to converge or -* were not computed: -* =1 or 3: Bisection failed to converge for some -* eigenvalues; these eigenvalues are flagged by a -* negative block number. The effect is that the -* eigenvalues may not be as accurate as the -* absolute and relative tolerances. This is -* generally caused by unexpectedly inaccurate -* arithmetic. -* =2 or 3: RANGE='I' only: Not all of the eigenvalues -* IL:IU were found. -* Effect: M < IU+1-IL -* Cause: non-monotonic arithmetic, causing the -* Sturm sequence to be non-monotonic. -* Cure: recalculate, using RANGE='A', and pick -* out eigenvalues IL:IU. In some cases, -* increasing the PARAMETER "FUDGE" may -* make things work. -* = 4: RANGE='I', and the Gershgorin interval -* initially used was too small. No eigenvalues -* were computed. -* Probable cause: your machine has sloppy -* floating-point arithmetic. -* Cure: Increase the PARAMETER "FUDGE", -* recompile, and try again. -* -* Internal Parameters -* =================== -* -* RELFAC REAL(DOUBLE), default = 2.0e0 -* The relative tolerance. An interval (a,b] lies within -* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), -* where "ulp" is the machine precision (distance from 1 to -* the next larger floating point number.) -* -* FUDGE REAL(DOUBLE), default = 2 -* A "fudge factor" to widen the Gershgorin intervals. Ideally, -* a value of 1 should work, but on machines with sloppy -* arithmetic, this needs to be larger. The default for -* publicly released versions should be large enough to handle -* the worst machine around. Note that this has no effect -* on accuracy of the solution. -* -! lowest_mode_num: (output) INTEGER mode number of lowest mode calculated - -! highest_mode_num: (output) INTEGER mode number of highest mode calculated - -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE, TWO, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ HALF = 1.0D0 / TWO ) - REAL(DOUBLE) FUDGE, RELFAC - PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL NCNVRG, TOOFEW - INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, - $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, - $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, - $ NWU - REAL(DOUBLE) ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, - $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL -* .. -* .. Local Arrays .. - INTEGER IDUMMA( 1 ) -* .. -* .. External Functions .. - - LOGICAL LSAME - EXTERNAL LSAME - - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH - - INTEGER ILAENV - EXTERNAL ILAENV - -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT -* .. -* .. Executable Statements .. - -* - INFO = 0 -* -* Decode RANGE -* - IF( LSAME( RANGE, 'A' ) ) THEN - IRANGE = 1 - ELSE IF( LSAME( RANGE, 'V' ) ) THEN - IRANGE = 2 - ELSE IF( LSAME( RANGE, 'I' ) ) THEN - IRANGE = 3 - ELSE - IRANGE = 0 - END IF -* -* Decode ORDER -* - IF( LSAME( ORDER, 'B' ) ) THEN - IORDER = 2 - ELSE IF( LSAME( ORDER, 'E' ) ) THEN - IORDER = 1 - ELSE - IORDER = 0 - END IF -* -* Check for Errors -* - IF( IRANGE.LE.0 ) THEN - INFO = -1 - ELSE IF( IORDER.LE.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( IRANGE.EQ.2 ) THEN - IF( VL.GE.VU ) - $ INFO = -5 - ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) - $ THEN - INFO = -6 - ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) - $ THEN - INFO = -7 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEBZ', -INFO ) - RETURN - END IF -* -* Initialize error flags -* - INFO = 0 - NCNVRG = .FALSE. - TOOFEW = .FALSE. -* -* Quick return if possible -* - M = 0 - IF( N.EQ.0 ) - $ RETURN -* -* Simplifications: -* - IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) - $ IRANGE = 1 -* -* Get machine constants -* NB is the minimum vector length for vector bisection, or 0 -* if only scalar is to be done. -* - SAFEMN = DLAMCH( 'S' ) - ULP = DLAMCH( 'P' ) - RTOLI = ULP*RELFAC - NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) - IF( NB.LE.1 ) - $ NB = 0 -* -* Special Case when N=1 -* - IF( N.EQ.1 ) THEN - NSPLIT = 1 - ISPLIT( 1 ) = 1 - IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN - M = 0 - ELSE - W( 1 ) = D( 1 ) - IBLOCK( 1 ) = 1 - M = 1 - END IF - highest_mode_num = 1 - lowest_mode_num = 1 - RETURN - END IF -* -* Compute Splitting Points -* - NSPLIT = 1 - WORK( N ) = ZERO - PIVMIN = ONE -* -*DIR$ NOVECTOR - DO 10 J = 2, N - TMP1 = E( J-1 )**2 - IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN - ISPLIT( NSPLIT ) = J - 1 - NSPLIT = NSPLIT + 1 - WORK( J-1 ) = ZERO - ELSE - WORK( J-1 ) = TMP1 - PIVMIN = MAX( PIVMIN, TMP1 ) - END IF - 10 CONTINUE - ISPLIT( NSPLIT ) = N - PIVMIN = PIVMIN*SAFEMN -* -* Compute Interval and ATOLI -* - IF( IRANGE.EQ.3 ) THEN -* -* RANGE='I': Compute the interval containing eigenvalues -* IL through IU. -* -* Compute Gershgorin interval for entire (split) matrix -* and use it as the initial interval -* - GU = D( 1 ) - GL = D( 1 ) - TMP1 = ZERO -* - DO 20 J = 1, N - 1 - TMP2 = SQRT( WORK( J ) ) - GU = MAX( GU, D( J )+TMP1+TMP2 ) - GL = MIN( GL, D( J )-TMP1-TMP2 ) - TMP1 = TMP2 - 20 CONTINUE -* - GU = MAX( GU, D( N )+TMP1 ) - GL = MIN( GL, D( N )-TMP1 ) - TNORM = MAX( ABS( GL ), ABS( GU ) ) - GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN - GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN -* -* Compute Iteration parameters -* - ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / - $ LOG( TWO ) ) + 2 - IF( ABSTOL.LE.ZERO ) THEN - ATOLI = ULP*TNORM - ELSE - ATOLI = ABSTOL - END IF -* - WORK( N+1 ) = GL - WORK( N+2 ) = GL - WORK( N+3 ) = GU - WORK( N+4 ) = GU - WORK( N+5 ) = GL - WORK( N+6 ) = GU - IWORK( 1 ) = -1 - IWORK( 2 ) = -1 - IWORK( 3 ) = N + 1 - IWORK( 4 ) = N + 1 - IWORK( 5 ) = IL - 1 - IWORK( 6 ) = IU -* - CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, - $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, - $ IWORK, W, IBLOCK, IINFO ) -! /////////////////////////////////////////////////////////////////////B - if (iinfo > 0) then - if ((iinfo >=1) .and. (iinfo <=2)) then - Write(err,801) subr_name,iinfo - Write(f06,801) subr_name,iinfo - fatal_err = fatal_err + 1 - else - Write(err,802) subr_name,iinfo - Write(f06,802) subr_name,iinfo - fatal_err = fatal_err + 1 - endif - endif -! /////////////////////////////////////////////////////////////////////E -* - IF( IWORK( 6 ).EQ.IU ) THEN - WL = WORK( N+1 ) - WLU = WORK( N+3 ) - NWL = IWORK( 1 ) - WU = WORK( N+4 ) - WUL = WORK( N+2 ) - NWU = IWORK( 4 ) - ELSE - WL = WORK( N+2 ) - WLU = WORK( N+4 ) - NWL = IWORK( 2 ) - WU = WORK( N+3 ) - WUL = WORK( N+1 ) - NWU = IWORK( 3 ) - END IF -* - IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN - INFO = 4 - RETURN - END IF - ELSE -* -* RANGE='A' or 'V' -- Set ATOLI -* - TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), - $ ABS( D( N ) )+ABS( E( N-1 ) ) ) -* - DO 30 J = 2, N - 1 - TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ - $ ABS( E( J ) ) ) - 30 CONTINUE -* - IF( ABSTOL.LE.ZERO ) THEN - ATOLI = ULP*TNORM - ELSE - ATOLI = ABSTOL - END IF -* - IF( IRANGE.EQ.2 ) THEN - WL = VL - WU = VU - ELSE - WL = ZERO - WU = ZERO - END IF - END IF -* -* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. -* NWL accumulates the number of eigenvalues .le. WL, -* NWU accumulates the number of eigenvalues .le. WU -* - M = 0 - IEND = 0 - INFO = 0 - NWL = 0 - NWU = 0 -* - write(sc1,*) - DO 70 JB = 1, NSPLIT - write(sc1,12345,advance='no') jb,nsplit,cr13_lge - IOFF = IEND - IBEGIN = IOFF + 1 - IEND = ISPLIT( JB ) - IN = IEND - IOFF -* - IF( IN.EQ.1 ) THEN -* -* Special Case -- IN=1 -* - IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) - $ NWL = NWL + 1 - IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) - $ NWU = NWU + 1 - IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. - $ D( IBEGIN )-PIVMIN ) ) THEN - M = M + 1 - W( M ) = D( IBEGIN ) - IBLOCK( M ) = JB - END IF - ELSE -* -* General Case -- IN > 1 -* -* Compute Gershgorin Interval -* and use it as the initial interval -* - GU = D( IBEGIN ) - GL = D( IBEGIN ) - TMP1 = ZERO -* - DO 40 J = IBEGIN, IEND - 1 - TMP2 = ABS( E( J ) ) - GU = MAX( GU, D( J )+TMP1+TMP2 ) - GL = MIN( GL, D( J )-TMP1-TMP2 ) - TMP1 = TMP2 - 40 CONTINUE -* - GU = MAX( GU, D( IEND )+TMP1 ) - GL = MIN( GL, D( IEND )-TMP1 ) - BNORM = MAX( ABS( GL ), ABS( GU ) ) - GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN - GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN -* -* Compute ATOLI for the current submatrix -* - IF( ABSTOL.LE.ZERO ) THEN - ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) ) - ELSE - ATOLI = ABSTOL - END IF -* - IF( IRANGE.GT.1 ) THEN - IF( GU.LT.WL ) THEN - NWL = NWL + IN - NWU = NWU + IN - GO TO 70 - END IF - GL = MAX( GL, WL ) - GU = MIN( GU, WU ) - IF( GL.GE.GU ) - $ GO TO 70 - END IF -* -* Set Up Initial Interval -* - WORK( N+1 ) = GL - WORK( N+IN+1 ) = GU - CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, - $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), - $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, - $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) -* - NWL = NWL + IWORK( 1 ) - NWU = NWU + IWORK( IN+1 ) - IWOFF = M - IWORK( 1 ) -* -* Compute Eigenvalues -* - ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / - $ LOG( TWO ) ) + 2 - CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, - $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), - $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, - $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) - -! /////////////////////////////////////////////////////////////////////B - if (iinfo > 0) then - if ((iinfo >=1) .and. (iinfo <=in)) then - Write(err,801) subr_name,iinfo - Write(f06,801) subr_name,iinfo - fatal_err = fatal_err + 1 - else - Write(err,802) subr_name,iinfo - Write(f06,802) subr_name,iinfo - fatal_err = fatal_err + 1 - endif - endif -! /////////////////////////////////////////////////////////////////////E -* -* Copy Eigenvalues Into W and IBLOCK -* Use -JB for block number for unconverged eigenvalues. -* - DO 60 J = 1, IOUT - TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) -* -* Flag non-convergence. -* - IF( J.GT.IOUT-IINFO ) THEN - NCNVRG = .TRUE. - IB = -JB - ELSE - IB = JB - END IF - DO 50 JE = IWORK( J ) + 1 + IWOFF, - $ IWORK( J+IN ) + IWOFF - W( JE ) = TMP1 - IBLOCK( JE ) = IB - 50 CONTINUE - 60 CONTINUE -* - M = M + IM - END IF - 70 CONTINUE -* -* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU -* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. -* - IF( IRANGE.EQ.3 ) THEN - IM = 0 - IDISCL = IL - 1 - NWL - IDISCU = NWU - IU -* - IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN - DO 80 JE = 1, M - IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN - IDISCL = IDISCL - 1 - ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN - IDISCU = IDISCU - 1 - ELSE - IM = IM + 1 - W( IM ) = W( JE ) - IBLOCK( IM ) = IBLOCK( JE ) - END IF - 80 CONTINUE - M = IM - END IF - IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN -* -* Code to deal with effects of bad arithmetic: -* Some low eigenvalues to be discarded are not in (WL,WLU], -* or high eigenvalues to be discarded are not in (WUL,WU] -* so just kill off the smallest IDISCL/largest IDISCU -* eigenvalues, by simply finding the smallest/largest -* eigenvalue(s). -* -* (If N(w) is monotone non-decreasing, this should never -* happen.) -* - IF( IDISCL.GT.0 ) THEN - WKILL = WU - DO 100 JDISC = 1, IDISCL - IW = 0 - DO 90 JE = 1, M - IF( IBLOCK( JE ).NE.0 .AND. - $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN - IW = JE - WKILL = W( JE ) - END IF - 90 CONTINUE - IBLOCK( IW ) = 0 - 100 CONTINUE - END IF - IF( IDISCU.GT.0 ) THEN -* - WKILL = WL - DO 120 JDISC = 1, IDISCU - IW = 0 - DO 110 JE = 1, M - IF( IBLOCK( JE ).NE.0 .AND. - $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN - IW = JE - WKILL = W( JE ) - END IF - 110 CONTINUE - IBLOCK( IW ) = 0 - 120 CONTINUE - END IF - IM = 0 - DO 130 JE = 1, M - IF( IBLOCK( JE ).NE.0 ) THEN - IM = IM + 1 - W( IM ) = W( JE ) - IBLOCK( IM ) = IBLOCK( JE ) - END IF - 130 CONTINUE - M = IM - END IF - IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN - TOOFEW = .TRUE. - END IF - END IF -* -* If ORDER='B', do nothing -- the eigenvalues are already sorted -* by block. -* If ORDER='E', sort the eigenvalues from smallest to largest -* - IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN - DO 150 JE = 1, M - 1 - IE = 0 - TMP1 = W( JE ) - DO 140 J = JE + 1, M - IF( W( J ).LT.TMP1 ) THEN - IE = J - TMP1 = W( J ) - END IF - 140 CONTINUE -* - IF( IE.NE.0 ) THEN - ITMP1 = IBLOCK( IE ) - W( IE ) = W( JE ) - IBLOCK( IE ) = IBLOCK( JE ) - W( JE ) = TMP1 - IBLOCK( JE ) = ITMP1 - END IF - 150 CONTINUE - END IF -* - highest_mode_num = nwu - lowest_mode_num = highest_mode_num - m + 1 - - INFO = 0 - IF( NCNVRG ) - $ INFO = INFO + 1 - IF( TOOFEW ) - $ INFO = INFO + 2 - - - RETURN -* -* End of DSTEBZ -* -! ********************************************************************************************************************************** -12345 format(5X,'Block ',i8,' of ',i8, a) - - 801 format(' *ERROR 801: ERROR ATTEMPTING TO SOLVE FOR EIGENVALUES', - &'. IN SUBROUTINE DLAEBZ, (CALLED FROM SUBR ',A,')' - & ,/,14X,' THE LAST ',I8,' INTERVALS DID NOT CONVERGE') - - 802 format(' *ERROR 802: ERROR ATTEMPTING TO SOLVE FOR EIGENVALUES', - &'. IN SUBROUTINE DLAEBZ, (CALLED FROM SUBR ',A,')' - & ,/,14X,' TOO MANY INTERVALS WERE GENERATED. MAX IS ',I8) - - -! ********************************************************************************************************************************** - - END SUBROUTINE DSTEBZ - -! ################################################################################################################################## -! 007 LAPACK_GIV_MGIV_EIG - - SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, - $ IWORK, IFAIL, INFO ) -* - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSTEIN' - -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDZ, M, N -* .. -* .. Array Arguments .. - INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), - $ IWORK( * ) - REAL(DOUBLE) D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSTEIN computes the eigenvectors of a real symmetric tridiagonal -* matrix T corresponding to specified eigenvalues, using inverse -* iteration. -* -* The maximum number of iterations allowed for each eigenvector is -* specified by an internal parameter MAXITS (currently set to 5). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input) REAL(DOUBLE) array, dimension (N) -* The n diagonal elements of the tridiagonal matrix T. -* -* E (input) REAL(DOUBLE) array, dimension (N) -* The (n-1) subdiagonal elements of the tridiagonal matrix -* T, in elements 1 to N-1. E(N) need not be set. -* -* M (input) INTEGER -* The number of eigenvectors to be found. 0 <= M <= N. -* -* W (input) REAL(DOUBLE) array, dimension (N) -* The first M elements of W contain the eigenvalues for -* which eigenvectors are to be computed. The eigenvalues -* should be grouped by split-off block and ordered from -* smallest to largest within the block. ( The output array -* W from DSTEBZ with ORDER = 'B' is expected here. ) -* -* IBLOCK (input) INTEGER array, dimension (N) -* The submatrix indices associated with the corresponding -* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to -* the first submatrix from the top, =2 if W(i) belongs to -* the second submatrix, etc. ( The output array IBLOCK -* from DSTEBZ is expected here. ) -* -* ISPLIT (input) INTEGER array, dimension (N) -* The splitting points, at which T breaks up into submatrices. -* The first submatrix consists of rows/columns 1 to -* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 -* through ISPLIT( 2 ), etc. -* ( The output array ISPLIT from DSTEBZ is expected here. ) -* -* Z (output) REAL(DOUBLE) array, dimension (LDZ, M) -* The computed eigenvectors. The eigenvector associated -* with the eigenvalue W(i) is stored in the i-th column of -* Z. Any vector which fails to converge is set to its current -* iterate after MAXITS iterations. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= max(1,N). -* -* WORK (workspace) REAL(DOUBLE) array, dimension (5*N) -* -* IWORK (workspace) INTEGER array, dimension (N) -* -* IFAIL (output) INTEGER array, dimension (M) -* On normal exit, all elements of IFAIL are zero. -* If one or more eigenvectors fail to converge after -* MAXITS iterations, then their indices are stored in -* array IFAIL. -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, then i eigenvectors failed to converge -* in MAXITS iterations. Their indices are stored in -* array IFAIL. -* -* Internal Parameters -* =================== -* -* MAXITS INTEGER, default = 5 -* The maximum number of iterations performed. -* -* EXTRA INTEGER, default = 2 -* The number of iterations performed after norm growth -* criterion is satisfied, should be at least 1. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE, TEN, ODM3, ODM1 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, - $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) - INTEGER MAXITS, EXTRA - PARAMETER ( MAXITS = 5, EXTRA = 2 ) -* .. -* .. Local Scalars .. - INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, - $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, - $ JBLK, JMAX, NBLK, NRMCHK - REAL(DOUBLE) DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, - $ SCL, SEP, TOL, XJ, XJM, ZTR -* .. -* .. Local Arrays .. - INTEGER ISEED( 4 ) -* .. -* .. External Functions .. - - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* - -* Test the input parameters. -* - INFO = 0 - DO 10 I = 1, M - IFAIL( I ) = 0 - 10 CONTINUE -* - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 .OR. M.GT.N ) THEN - INFO = -4 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE - DO 20 J = 2, M - IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN - INFO = -6 - GO TO 30 - END IF - IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) - $ THEN - INFO = -5 - GO TO 30 - END IF - 20 CONTINUE - 30 CONTINUE - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEIN', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - Z( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - EPS = DLAMCH( 'Precision' ) -* -* Initialize seed for random number generator DLARNV. -* - DO 40 I = 1, 4 - ISEED( I ) = 1 - 40 CONTINUE -* -* Initialize pointers. -* - INDRV1 = 0 - INDRV2 = INDRV1 + N - INDRV3 = INDRV2 + N - INDRV4 = INDRV3 + N - INDRV5 = INDRV4 + N -* -* Compute eigenvectors of matrix blocks. -* - J1 = 1 - DO 160 NBLK = 1, IBLOCK( M ) -* -* Find starting and ending indices of block nblk. -* - IF( NBLK.EQ.1 ) THEN - B1 = 1 - ELSE - B1 = ISPLIT( NBLK-1 ) + 1 - END IF - BN = ISPLIT( NBLK ) - BLKSIZ = BN - B1 + 1 - IF( BLKSIZ.EQ.1 ) - $ GO TO 60 - GPIND = B1 -* -* Compute reorthogonalization criterion and stopping criterion. -* - ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) - ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) - DO 50 I = B1 + 1, BN - 1 - ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ - $ ABS( E( I ) ) ) - 50 CONTINUE - ORTOL = ODM3*ONENRM -* - DTPCRT = SQRT( ODM1 / BLKSIZ ) -* -* Loop through eigenvalues of block nblk. -* - 60 CONTINUE - JBLK = 0 - DO 150 J = J1, M - IF( IBLOCK( J ).NE.NBLK ) THEN - J1 = J - GO TO 160 - END IF - JBLK = JBLK + 1 - XJ = W( J ) -* -* Skip all the work if the block size is one. -* - IF( BLKSIZ.EQ.1 ) THEN - WORK( INDRV1+1 ) = ONE - GO TO 120 - END IF -* -* If eigenvalues j and j-1 are too close, add a relatively -* small perturbation. -* - IF( JBLK.GT.1 ) THEN - EPS1 = ABS( EPS*XJ ) - PERTOL = TEN*EPS1 - SEP = XJ - XJM - IF( SEP.LT.PERTOL ) - $ XJ = XJM + PERTOL - END IF -* - ITS = 0 - NRMCHK = 0 -* -* Get random starting vector. -* - CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) -* -* Copy the matrix T so it won't be destroyed in factorization. -* - CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) - CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) - CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) -* -* Compute LU factors with partial pivoting ( PT = LU ) -* - TOL = ZERO - CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), - $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, - $ IINFO ) -* -* Update iteration count. -* - 70 CONTINUE - ITS = ITS + 1 - IF( ITS.GT.MAXITS ) - $ GO TO 100 -* -* Normalize and scale the righthand side vector Pb. -* - SCL = BLKSIZ*ONENRM*MAX( EPS, - $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / - $ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 ) - CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) -* -* Solve the system LU = Pb. -* - CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), - $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, - $ WORK( INDRV1+1 ), TOL, IINFO ) -* -* Reorthogonalize by modified Gram-Schmidt if eigenvalues are -* close enough. -* - IF( JBLK.EQ.1 ) - $ GO TO 90 - IF( ABS( XJ-XJM ).GT.ORTOL ) - $ GPIND = J - IF( GPIND.NE.J ) THEN - DO 80 I = GPIND, J - 1 - ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), - $ 1 ) - CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, - $ WORK( INDRV1+1 ), 1 ) - 80 CONTINUE - END IF -* -* Check the infinity norm of the iterate. -* - 90 CONTINUE - JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) - NRM = ABS( WORK( INDRV1+JMAX ) ) -* -* Continue for additional iterations after norm reaches -* stopping criterion. -* - IF( NRM.LT.DTPCRT ) - $ GO TO 70 - NRMCHK = NRMCHK + 1 - IF( NRMCHK.LT.EXTRA+1 ) - $ GO TO 70 -* - GO TO 110 -* -* If stopping criterion was not satisfied, update info and -* store eigenvector number in array ifail. -* - 100 CONTINUE - INFO = INFO + 1 - IFAIL( INFO ) = J -* -* Accept iterate as jth eigenvector. -* - 110 CONTINUE - SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) - JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) - IF( WORK( INDRV1+JMAX ).LT.ZERO ) - $ SCL = -SCL - CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) - 120 CONTINUE - DO 130 I = 1, N - Z( I, J ) = ZERO - 130 CONTINUE - DO 140 I = 1, BLKSIZ - Z( B1+I-1, J ) = WORK( INDRV1+I ) - 140 CONTINUE -* -* Save the shift to check eigenvalue spacing at next -* iteration. -* - XJM = XJ -* - 150 CONTINUE - 160 CONTINUE -* - RETURN -* -* End of DSTEIN -* - END SUBROUTINE DSTEIN - -! ################################################################################################################################## -! 008 LAPACK_GIV_MGIV_EIG - - SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DLAGTF' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, N - REAL(DOUBLE) LAMBDA, TOL -* .. -* .. Array Arguments .. - INTEGER IN( * ) - REAL(DOUBLE) A( * ), B( * ), C( * ), D( * ) -* .. -* -* Purpose -* ======= -* -* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n -* tridiagonal matrix and lambda is a scalar, as -* -* T - lambda*I = PLU, -* -* where P is a permutation matrix, L is a unit lower tridiagonal matrix -* with at most one non-zero sub-diagonal elements per column and U is -* an upper triangular matrix with at most two non-zero super-diagonal -* elements per column. -* -* The factorization is obtained by Gaussian elimination with partial -* pivoting and implicit row scaling. -* -* The parameter LAMBDA is included in the routine so that DLAGTF may -* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by -* inverse iteration. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix T. -* -* A (input/output) REAL(DOUBLE) array, dimension (N) -* On entry, A must contain the diagonal elements of T. -* -* On exit, A is overwritten by the n diagonal elements of the -* upper triangular matrix U of the factorization of T. -* -* LAMBDA (input) REAL(DOUBLE) -* On entry, the scalar lambda. -* -* B (input/output) REAL(DOUBLE) array, dimension (N-1) -* On entry, B must contain the (n-1) super-diagonal elements of -* T. -* -* On exit, B is overwritten by the (n-1) super-diagonal -* elements of the matrix U of the factorization of T. -* -* C (input/output) REAL(DOUBLE) array, dimension (N-1) -* On entry, C must contain the (n-1) sub-diagonal elements of -* T. -* -* On exit, C is overwritten by the (n-1) sub-diagonal elements -* of the matrix L of the factorization of T. -* -* TOL (input) REAL(DOUBLE) -* On entry, a relative tolerance used to indicate whether or -* not the matrix (T - lambda*I) is nearly singular. TOL should -* normally be chose as approximately the largest relative error -* in the elements of T. For example, if the elements of T are -* correct to about 4 significant figures, then TOL should be -* set to about 5*10**(-4). If TOL is supplied as less than eps, -* where eps is the relative machine precision, then the value -* eps is used in place of TOL. -* -* D (output) REAL(DOUBLE) array, dimension (N-2) -* On exit, D is overwritten by the (n-2) second super-diagonal -* elements of the matrix U of the factorization of T. -* -* IN (output) INTEGER array, dimension (N) -* On exit, IN contains details of the permutation matrix P. If -* an interchange occurred at the kth step of the elimination, -* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) -* returns the smallest positive integer j such that -* -* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, -* -* where norm( A(j) ) denotes the sum of the absolute values of -* the jth row of the matrix A. If no such j exists then IN(n) -* is returned as zero. If IN(n) is returned as positive, then a -* diagonal element of U is small, indicating that -* (T - lambda*I) is singular or nearly singular, -* -* INFO (output) INTEGER -* = 0 : successful exit -* .lt. 0: if INFO = -k, the kth argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER K - REAL(DOUBLE) EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. External Functions .. - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. -* .. -* .. Executable Statements .. - -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DLAGTF', -INFO ) - RETURN - END IF -* - IF( N.EQ.0 ) - $ RETURN -* - A( 1 ) = A( 1 ) - LAMBDA - IN( N ) = 0 - IF( N.EQ.1 ) THEN - IF( A( 1 ).EQ.ZERO ) - $ IN( 1 ) = 1 - RETURN - END IF -* - EPS = DLAMCH( 'Epsilon' ) -* - TL = MAX( TOL, EPS ) - SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) ) - DO 10 K = 1, N - 1 - A( K+1 ) = A( K+1 ) - LAMBDA - SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) ) - IF( K.LT.( N-1 ) ) - $ SCALE2 = SCALE2 + ABS( B( K+1 ) ) - IF( A( K ).EQ.ZERO ) THEN - PIV1 = ZERO - ELSE - PIV1 = ABS( A( K ) ) / SCALE1 - END IF - IF( C( K ).EQ.ZERO ) THEN - IN( K ) = 0 - PIV2 = ZERO - SCALE1 = SCALE2 - IF( K.LT.( N-1 ) ) - $ D( K ) = ZERO - ELSE - PIV2 = ABS( C( K ) ) / SCALE2 - IF( PIV2.LE.PIV1 ) THEN - IN( K ) = 0 - SCALE1 = SCALE2 - C( K ) = C( K ) / A( K ) - A( K+1 ) = A( K+1 ) - C( K )*B( K ) - IF( K.LT.( N-1 ) ) - $ D( K ) = ZERO - ELSE - IN( K ) = 1 - MULT = A( K ) / C( K ) - A( K ) = C( K ) - TEMP = A( K+1 ) - A( K+1 ) = B( K ) - MULT*TEMP - IF( K.LT.( N-1 ) ) THEN - D( K ) = B( K+1 ) - B( K+1 ) = -MULT*D( K ) - END IF - B( K ) = TEMP - C( K ) = MULT - END IF - END IF - IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) ) - $ IN( N ) = K - 10 CONTINUE - IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) ) - $ IN( N ) = N -* - RETURN - -* -* End of DLAGTF -* - END SUBROUTINE DLAGTF - - END MODULE LAPACK_GIV_MGIV_EIG diff --git a/Source/Modules/LAPACK/LAPACK_LANCZOS_EIG.f b/Source/Modules/LAPACK/LAPACK_LANCZOS_EIG.f deleted file mode 100644 index 70f72ee1..00000000 --- a/Source/Modules/LAPACK/LAPACK_LANCZOS_EIG.f +++ /dev/null @@ -1,370 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_LANCZOS_EIG - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE SCONTR, ONLY : BLNK_SUB_NAM - USE TIMDAT, ONLY : TSEC - USE LAPACK_BLAS_AUX - - USE OURTIM_Interface - -! This is the set of LAPACK routines used by the Lanczos algorithm contained in module ARPACK_LANCZOS_EIG -! The following routines are contained: - -! DGEQR2: to compute a QR factorization of a real m by n matrix A: -! A = Q * R. - -! DORM2R: to overwrite the general real m by n matrix C with -! -! Q * C if SIDE = 'L' and TRANS = 'N', or -! -! Q'* C if SIDE = 'L' and TRANS = 'T', or -! -! C * Q if SIDE = 'R' and TRANS = 'N', or -! -! C * Q' if SIDE = 'R' and TRANS = 'T', -! -! where Q is a real orthogonal matrix defined as the product of k elementary reflectors - - CONTAINS - -! ################################################################################################################################## -! 001 LAPACK_LANCZOS_EIG - - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSTEQR' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQR2 computes a QR factorization of a real m by n matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(m,n) by n upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) REAL(DOUBLE) array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) REAL(DOUBLE) array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - REAL(DOUBLE) AII -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - - RETURN -* -* End of DGEQR2 -* - END SUBROUTINE DGEQR2 - -! ################################################################################################################################## -! 002 LAPACK_LANCZOS_EIG - - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = '' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORM2R overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q' (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) REAL(DOUBLE) array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) REAL(DOUBLE) array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) REAL(DOUBLE) array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) REAL(DOUBLE) array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - REAL(DOUBLE) AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. - -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - - RETURN -* -* End of DORM2R -* - END SUBROUTINE DORM2R - - END MODULE LAPACK_LANCZOS_EIG diff --git a/Source/Modules/LAPACK/LAPACK_LIN_EQN_DGB.f b/Source/Modules/LAPACK/LAPACK_LIN_EQN_DGB.f deleted file mode 100644 index 58e4ee50..00000000 --- a/Source/Modules/LAPACK/LAPACK_LIN_EQN_DGB.f +++ /dev/null @@ -1,905 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_LIN_EQN_DGB - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06, SC1 - USE SCONTR, ONLY : LINKNO, BLNK_SUB_NAM - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, STIME, TSEC - USE LAPACK_BLAS_AUX - - USE OURTIM_Interface - USE OUTA_HERE_Interface - - character(1*byte), parameter :: cr13_dgb = char(13) - CHARACTER(44*BYTE), PRIVATE :: MODNAM ! Name to write to screen to describe module being run. - -! This is a set of LAPACK routines for factorization and solution of linear eqns for general band matrices - -! DGBTRF: Driver to compute a LU factorization of a real m-by-n band matrix A using partial pivoting with row interchanges. - -! DGBTRS: to solve a system of linear equations -! A * X = B or A' * X = B -! with a general band matrix A using the LU factorization computed by DGBTRF. - -! DGBTF2: to compute a LU factorization of a real m-by-n band matrix A using partial pivoting with row interchanges. -! This subroutine is called by DGBTRF - - CONTAINS - -! ################################################################################################################################## -! 001 LAPACK_LINEAR_EQN_DGB - - SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DGBTRF' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL(DOUBLE) AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* DGBTRF computes an LU factorization of a real m-by-n band matrix A -* using partial pivoting with row interchanges. -* -* This is the blocked version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB,N) -* On entry, the matrix A in band storage, in rows KL+1 to -* 2*KL+KU+1; rows 1 to KL of the array need not be set. -* The j-th column of A is stored in the j-th column of the -* array AB as follows: -* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -* -* On exit, details of the factorization: U is stored as an -* upper triangular band matrix with KL+KU superdiagonals in -* rows 1 to KL+KU+1, and the multipliers used during the -* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -* See below for further details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* M = N = 6, KL = 2, KU = 1: -* -* On entry: On exit: -* -* * * * + + + * * * u14 u25 u36 -* * * + + + + * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -* -* Array elements marked * are not used by the routine; elements marked -* + need not be set on entry, but are required by the routine to store -* elements of U because of fill-in resulting from the row interchanges. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - INTEGER NBMAX, LDWORK - PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) -* .. -* .. Local Scalars .. - INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, - $ JU, K2, KM, KV, NB, NW -! /////////////////////////////////////////////////////////////////////B -! Add this so we can use IMPLICIT NONE (switch "-in" when compiling) - integer numblk, iblock -! /////////////////////////////////////////////////////////////////////E - REAL(DOUBLE) TEMP -* .. -* .. Local Arrays .. - REAL(DOUBLE) WORK13( LDWORK, NBMAX ), - $ WORK31( LDWORK, NBMAX ) -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV - - -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment -* - NB = ILAENV( 1, 'DGBTRF', ' ', M, N, KL, KU ) -* -* The block size must not exceed the limit set by the size of the -* local arrays WORK13 and WORK31. -* - NB = MIN( NB, NBMAX ) -* - IF( NB.LE.1 .OR. NB.GT.KL ) THEN -* -* Use unblocked code -* - CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) - ELSE -* -* Use blocked code -* -* Zero the superdiagonal elements of the work array WORK13 -* - DO 20 J = 1, NB - DO 10 I = 1, J - 1 - WORK13( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* Zero the subdiagonal elements of the work array WORK31 -* - DO 40 J = 1, NB - DO 30 I = J + 1, NB - WORK31( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero -* - DO 60 J = KU + 2, MIN( KV, N ) - DO 50 I = KV - J + 2, KL - AB( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE -* -* JU is the index of the last column affected by the current -* stage of the factorization -* - JU = 1 -* - numblk = int(MIN(M,n)/nb) + 1 - iblock = 0 - WRITE (*,*) - DO 180 J = 1, MIN( M, N ), NB - iblock = iblock + 1 - JB = MIN( NB, MIN( M, N )-J+1 ) - write(sc1,12345,advance='no') iblock,numblk,jb,cr13_dgb -* -* The active part of the matrix is partitioned -* -* A11 A12 A13 -* A21 A22 A23 -* A31 A32 A33 -* -* Here A11, A21 and A31 denote the current block of JB columns -* which is about to be factorized. The number of rows in the -* partitioning are JB, I2, I3 respectively, and the numbers -* of columns are JB, J2, J3. The superdiagonal elements of A13 -* and the subdiagonal elements of A31 lie outside the band. -* - I2 = MIN( KL-JB, M-J-JB+1 ) - I3 = MIN( JB, M-J-KL+1 ) -* -* J2 and J3 are computed after JU has been updated. -* -* Factorize the current block of JB columns -* - DO 80 JJ = J, J + JB - 1 -* -* Set fill-in elements in column JJ+KV to zero -* - IF( JJ+KV.LE.N ) THEN - DO 70 I = 1, KL - AB( I, JJ+KV ) = ZERO - 70 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-JJ ) - JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 ) - IPIV( JJ ) = JP + JJ - J - IF( AB( KV+JP, JJ ).NE.ZERO ) THEN - JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to J+JB-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* - CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange affects columns J to JJ-1 of A31 -* which are stored in the work array WORK31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, - $ AB( KV+JP, JJ ), LDAB-1 ) - END IF - END IF -* -* Compute multipliers -* - CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), - $ 1 ) -* -* Update trailing submatrix within the band and within -* the current block. JM is the index of the last column -* which needs to be updated. -* - JM = MIN( JU, J+JB-1 ) - IF( JM.GT.JJ ) - $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, - $ AB( KV, JJ+1 ), LDAB-1, - $ AB( KV+1, JJ+1 ), LDAB-1 ) - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = JJ - END IF -* -* Copy current column of A31 into the work array WORK31 -* - NW = MIN( JJ-J+1, I3 ) - IF( NW.GT.0 ) - $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, - $ WORK31( 1, JJ-J+1 ), 1 ) - 80 CONTINUE - IF( J+JB.LE.N ) THEN -* -* Apply the row interchanges to the other blocks. -* - J2 = MIN( JU-J+1, KV ) - JB - J3 = MAX( 0, JU-J-KV+1 ) -* -* Use DLASWP to apply the row interchanges to A12, A22, and -* A32. -* - CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, - $ IPIV( J ), 1 ) -* -* Adjust the pivot indices. -* - DO 90 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 90 CONTINUE -* -* Apply the row interchanges to A13, A23, and A33 -* columnwise. -* - K2 = J - 1 + JB + J2 - DO 110 I = 1, J3 - JJ = K2 + I - DO 100 II = J + I - 1, J + JB - 1 - IP = IPIV( II ) - IF( IP.NE.II ) THEN - TEMP = AB( KV+1+II-JJ, JJ ) - AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) - AB( KV+1+IP-JJ, JJ ) = TEMP - END IF - 100 CONTINUE - 110 CONTINUE -* -* Update the relevant part of the trailing submatrix -* - IF( J2.GT.0 ) THEN -* -* Update A12 -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1 ) -* - IF( I2.GT.0 ) THEN -* -* Update A22 -* - CALL DGEMM( 'No transpose', 'No transpose', I2, J2, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+1, J+JB ), LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A32 -* - CALL DGEMM( 'No transpose', 'No transpose', I3, J2, - $ JB, -ONE, WORK31, LDWORK, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) - END IF - END IF -* - IF( J3.GT.0 ) THEN -* -* Copy the lower triangle of A13 into the work array -* WORK13 -* - DO 130 JJ = 1, J3 - DO 120 II = JJ, JB - WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) - 120 CONTINUE - 130 CONTINUE -* -* Update A13 in the work array -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, - $ WORK13, LDWORK ) -* - IF( I2.GT.0 ) THEN -* -* Update A23 -* - CALL DGEMM( 'No transpose', 'No transpose', I2, J3, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), - $ LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A33 -* - CALL DGEMM( 'No transpose', 'No transpose', I3, J3, - $ JB, -ONE, WORK31, LDWORK, WORK13, - $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) - END IF -* -* Copy the lower triangle of A13 back into place -* - DO 150 JJ = 1, J3 - DO 140 II = JJ, JB - AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE -* -* Adjust the pivot indices. -* - DO 160 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 160 CONTINUE - END IF -* -* Partially undo the interchanges in the current block to -* restore the upper triangular form of A31 and copy the upper -* triangle of A31 back into place -* - DO 170 JJ = J + JB - 1, J, -1 - JP = IPIV( JJ ) - JJ + 1 - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to JJ-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* -* The interchange does not affect A31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange does affect A31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - END IF - END IF -* -* Copy the current column of A31 back into place -* - NW = MIN( I3, JJ-J+1 ) - IF( NW.GT.0 ) - $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1, - $ AB( KV+KL+1-JJ+J, JJ ), 1 ) - 170 CONTINUE - 180 CONTINUE - END IF -* -12345 format(5X,'Block ',i8,' of ',i8,'. Factoring rows 1 thru: ',i8,a) - - RETURN -* -* End of DGBTRF -* - END SUBROUTINE DGBTRF - -! ################################################################################################################################## -! 002 LAPACK_LINEAR_EQN_DGB - - SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, - $ INFO, dtbsv_msg ) ! I added dtbsv_msg - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DGBTRS' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - character*1 dtbsv_msg - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL(DOUBLE) AB( LDAB, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGBTRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general band matrix A using the LU factorization computed -* by DGBTRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations. -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* AB (input) REAL(DOUBLE) array, dimension (LDAB,N) -* Details of the LU factorization of the band matrix A, as -* computed by DGBTRF. U is stored as an upper triangular band -* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and -* the multipliers used during the factorization are stored in -* rows KL+KU+2 to 2*KL+KU+1. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices; for 1 <= i <= N, row i of the matrix was -* interchanged with row IPIV(i). -* -* B (input/output) REAL(DOUBLE) array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -! dtbsv_msg (input) CHARACTER -! = 'Y', have subr DTBSV print Fwd, Back pass messages - -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LNOTI, NOTRAN - INTEGER I, J, KD, L, LM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - KD = KU + KL + 1 - LNOTI = KL.GT.0 -* - IF( NOTRAN ) THEN -* -* Solve A*X = B. -* -* Solve L*X = B, overwriting B with X. -* -* L is represented as a product of permutations and unit lower -* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -* where each transformation L(i) is a rank-one modification of -* the identity matrix. -* - IF( LNOTI ) THEN - DO 10 J = 1, N - 1 - LM = MIN( KL, N-J ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), - $ LDB, B( J+1, 1 ), LDB ) - 10 CONTINUE - END IF -* - DO 20 I = 1, NRHS -* -* Solve U*X = B, overwriting B with X. -* - CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, - $ AB, LDAB, B( 1, I ), 1, dtbsv_msg ) - 20 CONTINUE -* - ELSE -* -* Solve A'*X = B. -* - DO 30 I = 1, NRHS -* -* Solve U'*X = B, overwriting B with X. -* - write(sc1,*) - CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, - $ LDAB, B( 1, I ), 1, dtbsv_msg ) - 30 CONTINUE -* -* Solve L'*X = B, overwriting B with X. -* - IF( LNOTI ) THEN - DO 40 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), - $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - 40 CONTINUE - END IF - END IF - - RETURN -* -* End of DGBTRS -* - END SUBROUTINE DGBTRS - -! ################################################################################################################################## -! 003 LAPACK_LINEAR_EQN_DGB - - SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DGBTF2' -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL(DOUBLE) AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* DGBTF2 computes an LU factorization of a real m-by-n band matrix A -* using partial pivoting with row interchanges. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB,N) -* On entry, the matrix A in band storage, in rows KL+1 to -* 2*KL+KU+1; rows 1 to KL of the array need not be set. -* The j-th column of A is stored in the j-th column of the -* array AB as follows: -* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -* -* On exit, details of the factorization: U is stored as an -* upper triangular band matrix with KL+KU superdiagonals in -* rows 1 to KL+KU+1, and the multipliers used during the -* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -* See below for further details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* M = N = 6, KL = 2, KU = 1: -* -* On entry: On exit: -* -* * * * + + + * * * u14 u25 u36 -* * * + + + + * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -* -* Array elements marked * are not used by the routine; elements marked -* + need not be set on entry, but are required by the routine to store -* elements of U, because of fill-in resulting from the row -* interchanges. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, JP, JU, KM, KV -* .. -* .. External Functions .. -!!1 EXTERNAL IDAMAX -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in. -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero. -* - DO 20 J = KU + 2, MIN( KV, N ) - DO 10 I = KV - J + 2, KL - AB( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* JU is the index of the last column affected by the current stage -* of the factorization. -* - JU = 1 -* - DO 40 J = 1, MIN( M, N ) -* -* Set fill-in elements in column J+KV to zero. -* - IF( J+KV.LE.N ) THEN - DO 30 I = 1, KL - AB( I, J+KV ) = ZERO - 30 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-J ) - JP = IDAMAX( KM+1, AB( KV+1, J ), 1 ) - IPIV( J ) = JP + J - 1 - IF( AB( KV+JP, J ).NE.ZERO ) THEN - JU = MAX( JU, MIN( J+KU+JP-1, N ) ) -* -* Apply interchange to columns J to JU. -* - IF( JP.NE.1 ) - $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, - $ AB( KV+1, J ), LDAB-1 ) -* - IF( KM.GT.0 ) THEN -* -* Compute multipliers. -* - CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) -* -* Update trailing submatrix within the band. -* - IF( JU.GT.J ) - $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, - $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), - $ LDAB-1 ) - END IF - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = J - END IF - 40 CONTINUE - - RETURN -* -* End of DGBTF2 -* - END SUBROUTINE DGBTF2 - - END MODULE LAPACK_LIN_EQN_DGB diff --git a/Source/Modules/LAPACK/LAPACK_LIN_EQN_DGE.f b/Source/Modules/LAPACK/LAPACK_LIN_EQN_DGE.f deleted file mode 100644 index 60fb6e62..00000000 --- a/Source/Modules/LAPACK/LAPACK_LIN_EQN_DGE.f +++ /dev/null @@ -1,705 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_LIN_EQN_DGE - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06 - USE SCONTR, ONLY : LINKNO, BLNK_SUB_NAM - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, STIME, TSEC - USE PARAMS, ONLY : EPSIL - USE LAPACK_BLAS_AUX - - USE OURTIM_Interface - USE OUTA_HERE_Interface - - CHARACTER(44*BYTE), PRIVATE :: MODNAM ! Name to write to screen to describe module being run. - -! This is the set of LAPACK routines for solving equations - -! AX = B - -! where matrix A is a dbl prec general matrix (i.e., not symmetric). Matrix A is decomposed into an upper triangular matrix U -! such that (P is a permutation matrix): - -! A = P*L*U - -! This module contains the following subroutines: - -! DGETRF: driver for the triangular decomp of A - -! DGETRS: does the forward-backward substition. A seperate call to DGETRS must be made for each right hand side - -! DGETF2: which is called by DGETRF to do the actual decomp - - CONTAINS - -! ################################################################################################################################## -! 001 LAPACK_LINEAR_EQN_DGE - - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DGETRF' - -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL(DOUBLE) A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. -* - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Functions .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END SUBROUTINE DGETRF - -! ################################################################################################################################## -! 002 LAPACK_LINEAR_EQN_DGE - - SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DGETRF' - -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGETRI computes the inverse of a matrix using the LU factorization -* computed by DGETRF. -* -* This method inverts U and then computes inv(A) by solving the system -* inv(A)*L = inv(U) for inv(A). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the factors L and U from the factorization -* A = P*L*U as computed by DGETRF. -* On exit, if INFO = 0, the inverse of the original matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimal performance LWORK >= N*NB, where NB is -* the optimal blocksize returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is -* singular and its inverse could not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, - $ NBMIN, NN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - INFO = 0 - NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRI', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, -* and the inverse is not computed. -* - CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = MAX( LDWORK*NB, 1 ) - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) - END IF - ELSE - IWS = N - END IF -* -* Solve the equation inv(A)*L = inv(U) for inv(A). -* - IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - DO 20 J = N, 1, -1 -* -* Copy current column of L to WORK and replace with zeros. -* - DO 10 I = J + 1, N - WORK( I ) = A( I, J ) - A( I, J ) = ZERO - 10 CONTINUE -* -* Compute current column of inv(A). -* - IF( J.LT.N ) - $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), - $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) - 20 CONTINUE - ELSE -* -* Use blocked code. -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 50 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) -* -* Copy current block column of L to WORK and replace with -* zeros. -* - DO 40 JJ = J, J + JB - 1 - DO 30 I = JJ + 1, N - WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) - A( I, JJ ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Compute current block column of inv(A). -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, - $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, - $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, - $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) - 50 CONTINUE - END IF -* -* Apply column interchanges. -* - DO 60 J = N - 1, 1, -1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 60 CONTINUE -* - WORK( 1 ) = IWS - RETURN -* -* End of DGETRF -* - END SUBROUTINE DGETRI - -! ################################################################################################################################## -! 003 LAPACK_LINEAR_EQN_DGE - - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DGETRS' - -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL(DOUBLE) A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) REAL(DOUBLE) array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) REAL(DOUBLE) array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A' * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END SUBROUTINE DGETRS - -! ################################################################################################################################## -! 004 LAPACK_LINEAR_EQN_DGE - - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DGETF2' - -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL(DOUBLE) A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP -!xxx IF( A( JP, J ).NE.ZERO ) THEN - IF( DABS(A( JP, J )) > EPSIL(2)) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END SUBROUTINE DGETF2 - - END MODULE LAPACK_LIN_EQN_DGE diff --git a/Source/Modules/LAPACK/LAPACK_LIN_EQN_DPB.f b/Source/Modules/LAPACK/LAPACK_LIN_EQN_DPB.f deleted file mode 100644 index a29e198f..00000000 --- a/Source/Modules/LAPACK/LAPACK_LIN_EQN_DPB.f +++ /dev/null @@ -1,2112 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_LIN_EQN_DPB - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06 - USE SCONTR, ONLY : BLNK_SUB_NAM - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, TSEC - USE LAPACK_BLAS_AUX - USE PARAMS, ONLY : NOCOUNTS - - character(1*byte), parameter :: cr13_dpb = char(13) - -! This is the set of LAPACK routines for solving equations - -! Ax = B - -! where matrix A is a dbl prec symmetric banded matrix. -! Matrix A is decomposed into an upper triangular matrix U such that: - -! A = U(transp)*U - -! This module contains: - -! DPBEQU to equilize A by scaling using diagonals of A - -! DPBTRF to do the factorization of A by calling - -! DPBTF2 if A is unblocked to do factorization of A, or - -! DPOTF2 if A is blocked to do factorization of A - -! DPBCON to calculate the condition number of A, given it's triangular factors - -! DPBTRS to get the solution for x given the triangular factors of A - -! In addition, files in module LAPACK_BLAS_AUX are also used - - CONTAINS - -! ################################################################################################################################## -! 001 LAPACK_LINEAR_EQN_DPB - - SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBEQU' -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, KD, LDAB, N - REAL(DOUBLE) AMAX, SCOND -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ), S( * ) -* .. -* -* Purpose -* ======= -* -* DPBEQU computes row and column scalings intended to equilibrate a -* symmetric positive definite band matrix A and reduce its condition -* number (with respect to the two-norm). S contains the scale factors, -* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with -* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This -* choice of S puts the condition number of B within a factor N of the -* smallest possible condition number over all possible diagonal -* scalings. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangular of A is stored; -* = 'L': Lower triangular of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of superdiagonals of the matrix A if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KD >= 0. -* -* AB (input) REAL(DOUBLE) array, dimension (LDAB,N) -* The upper or lower triangle of the symmetric band matrix A, -* stored in the first KD+1 rows of the array. The j-th column -* of A is stored in the j-th column of the array AB as follows: -* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -* -* LDAB (input) INTEGER -* The leading dimension of the array A. LDAB >= KD+1. -* -* S (output) REAL(DOUBLE) array, dimension (N) -* If INFO = 0, S contains the scale factors for A. -* -* SCOND (output) REAL(DOUBLE) -* If INFO = 0, S contains the ratio of the smallest S(i) to -* the largest S(i). If SCOND >= 0.1 and AMAX is neither too -* large nor too small, it is not worth scaling by S. -* -* AMAX (output) REAL(DOUBLE) -* Absolute value of largest matrix element. If AMAX is very -* close to overflow or very close to underflow, the matrix -* should be scaled. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: if INFO = i, the i-th diagonal element is nonpositive. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, J - REAL(DOUBLE) SMIN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N < 0 ) THEN - INFO = -2 - ELSE IF( KD < 0 ) THEN - INFO = -3 - ELSE IF( LDAB < KD+1 ) THEN - INFO = -5 - END IF - IF( INFO /= 0 ) THEN - CALL XERBLA( 'DPBEQU', -INFO ) - go to 9000 ! My line - END IF -* -* Quick return if possible -* - IF( N == 0 ) THEN - SCOND = ONE - AMAX = ZERO - go to 9000 ! My line - END IF -* - IF( UPPER ) THEN - J = KD + 1 - ELSE - J = 1 - END IF -* -* Initialize SMIN and AMAX. -* - S( 1 ) = AB( J, 1 ) - SMIN = S( 1 ) - AMAX = S( 1 ) -* -* Find the minimum and maximum diagonal elements. -* - DO 10 I = 2, N - S( I ) = AB( J, I ) - SMIN = MIN( SMIN, S( I ) ) - AMAX = MAX( AMAX, S( I ) ) - 10 CONTINUE -* - IF( SMIN <= ZERO ) THEN -* -* Find the first non-positive diagonal element and return. -* - DO 20 I = 1, N - IF( S( I ) <= ZERO ) THEN - INFO = I - go to 9000 ! My line - END IF - 20 CONTINUE - ELSE -* -* Set the scale factors to the reciprocals -* of the diagonal elements. -* - DO 30 I = 1, N - S( I ) = ONE / SQRT( S( I ) ) - 30 CONTINUE -* -* Compute SCOND = min(S(I)) / max(S(I)) -* - SCOND = SQRT( SMIN ) / SQRT( AMAX ) - END IF - go to 9000 ! My line -* -* End of DPBEQU -* -! ********************************************************************************************************************************** - 9000 continue - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DPBEQU - -! ################################################################################################################################## -! 002 LAPACK_LINEAR_EQN_DPB - - SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBTRF' -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, KD, LDAB, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* DPBTRF computes the Cholesky factorization of a real symmetric -* positive definite band matrix A. -* -* The factorization has the form -* A = U**T * U, if UPLO = 'U', or -* A = L * L**T, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of superdiagonals of the matrix A if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KD >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB,N) -* On entry, the upper or lower triangle of the symmetric band -* matrix A, stored in the first KD+1 rows of the array. The -* j-th column of A is stored in the j-th column of the array AB -* as follows: -* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -* -* On exit, if INFO = 0, the triangular factor U or L from the -* Cholesky factorization A = U**T*U or A = L*L**T of the band -* matrix A, in the same storage format as A. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* iblock (local) INTEGER -* Block number that the calling program (DPBTRF) is working on -* -* numblk (local) INTEGER -* Total number of diagonal blocks that the calling program -* (DPBTRF) has to work on -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* N = 6, KD = 2, and UPLO = 'U': -* -* On entry: On exit: -* -* * * a13 a24 a35 a46 * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* -* Similarly, if UPLO = 'L' the format of A is as follows: -* -* On entry: On exit: -* -* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 -* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * -* a31 a42 a53 a64 * * l31 l42 l53 l64 * * -* -* Array elements marked * are not used by the routine. -* -* Contributed by -* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - INTEGER NBMAX, LDWORK - PARAMETER ( NBMAX = 32, LDWORK = NBMAX+1 ) -* .. -* .. Local Scalars .. - INTEGER I, I2, I3, IB, II, J, JJ, NB, iblock - & , numblk -* .. -* .. Local Arrays .. - REAL(DOUBLE) WORK( LDWORK, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 - ELSE IF( N < 0 ) THEN - INFO = -2 - ELSE IF( KD < 0 ) THEN - INFO = -3 - ELSE IF( LDAB < KD+1 ) THEN - INFO = -5 - END IF - IF( INFO /= 0 ) THEN - CALL XERBLA( 'DPBTRF', -INFO ) - go to 9000 ! My line - END IF -* -* Quick return if possible -* - IF( N == 0 ) - & go to 9000 ! My line -* -* Determine the block size for this environment -* - NB = ILAENV( 1, 'DPBTRF', UPLO, N, KD, -1, -1 ) -* -* The block size must not exceed the semi-bandwidth KD, and must not -* exceed the limit set by the size of the local array WORK. -* - NB = MIN( NB, NBMAX ) -* - IF( NB <= 1 .OR. NB > KD ) THEN -* -* Use unblocked code -* - CALL DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) - ELSE -* -* Use blocked code -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Compute the Cholesky factorization of a symmetric band -* matrix, given the upper triangle of the matrix in band -* storage. -* -* Zero the upper triangle of the work array. -* - DO 20 J = 1, NB - DO 10 I = 1, J - 1 - WORK( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* Process the band matrix one diagonal block at a time. -* - numblk = int(n/nb) + 1 - iblock = 0 - WRITE (*,*) - DO 70 I = 1, N, NB - iblock = iblock + 1 - IB = MIN( NB, N-I+1 ) -* -* Factorize the diagonal block -* - write(sc1,12345,advance='no') iblock,numblk,ib,cr13_dpb - CALL DPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II ) - IF( II /= 0 ) THEN - INFO = I + II - 1 - GO TO 150 - END IF - IF( I+IB <= N ) THEN -* -* Update the relevant part of the trailing submatrix. -* If A11 denotes the diagonal block which has just been -* factorized, then we need to update the remaining -* blocks in the diagram: -* -* A11 A12 A13 -* A22 A23 -* A33 -* -* The numbers of rows and columns in the partitioning -* are IB, I2, I3 respectively. The blocks A12, A22 and -* A23 are empty if IB = KD. The upper triangle of A13 -* lies outside the band. -* - I2 = MIN( KD-IB, N-I-IB+1 ) - I3 = MIN( IB, N-I-KD+1 ) -* - IF( I2 > 0 ) THEN -* -* Update A12 -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', - $ 'Non-unit', IB, I2, ONE, AB( KD+1, I ), - $ LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 ) -* -* Update A22 -* - CALL DSYRK( 'Upper', 'Transpose', I2, IB, -ONE, - $ AB( KD+1-IB, I+IB ), LDAB-1, ONE, - $ AB( KD+1, I+IB ), LDAB-1 ) - END IF -* - IF( I3 > 0 ) THEN -* -* Copy the lower triangle of A13 into the work array. -* - DO 40 JJ = 1, I3 - DO 30 II = JJ, IB - WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 ) - 30 CONTINUE - 40 CONTINUE -* -* Update A13 (in the work array). -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', - $ 'Non-unit', IB, I3, ONE, AB( KD+1, I ), - $ LDAB-1, WORK, LDWORK ) -* -* Update A23 -* - IF( I2 > 0 ) - $ CALL DGEMM( 'Transpose', 'No Transpose', I2, I3, - $ IB, -ONE, AB( KD+1-IB, I+IB ), - $ LDAB-1, WORK, LDWORK, ONE, - $ AB( 1+IB, I+KD ), LDAB-1 ) -* -* Update A33 -* - CALL DSYRK( 'Upper', 'Transpose', I3, IB, -ONE, - $ WORK, LDWORK, ONE, AB( KD+1, I+KD ), - $ LDAB-1 ) -* -* Copy the lower triangle of A13 back into place. -* - DO 60 JJ = 1, I3 - DO 50 II = JJ, IB - AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ ) - 50 CONTINUE - 60 CONTINUE - END IF - END IF - 70 CONTINUE - ELSE -* -* Compute the Cholesky factorization of a symmetric band -* matrix, given the lower triangle of the matrix in band -* storage. -* -* Zero the lower triangle of the work array. -* - DO 90 J = 1, NB - DO 80 I = J + 1, NB - WORK( I, J ) = ZERO - 80 CONTINUE - 90 CONTINUE -* -* Process the band matrix one diagonal block at a time. -* - numblk = int(n/nb) + 1 - iblock = 0 - WRITE (*,*) - DO 140 I = 1, N, NB - iblock = iblock + 1 - IB = MIN( NB, N-I+1 ) -* -* Factorize the diagonal block -* - write(sc1,12345,advance='no') iblock,numblk,ib,cr13_dpb - CALL DPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II ) - IF( II /= 0 ) THEN - INFO = I + II - 1 - GO TO 150 - END IF - IF( I+IB <= N ) THEN -* -* Update the relevant part of the trailing submatrix. -* If A11 denotes the diagonal block which has just been -* factorized, then we need to update the remaining -* blocks in the diagram: -* -* A11 -* A21 A22 -* A31 A32 A33 -* -* The numbers of rows and columns in the partitioning -* are IB, I2, I3 respectively. The blocks A21, A22 and -* A32 are empty if IB = KD. The lower triangle of A31 -* lies outside the band. -* - I2 = MIN( KD-IB, N-I-IB+1 ) - I3 = MIN( IB, N-I-KD+1 ) -* - IF( I2 > 0 ) THEN -* -* Update A21 -* - CALL DTRSM( 'Right', 'Lower', 'Transpose', - $ 'Non-unit', I2, IB, ONE, AB( 1, I ), - $ LDAB-1, AB( 1+IB, I ), LDAB-1 ) -* -* Update A22 -* - CALL DSYRK( 'Lower', 'No Transpose', I2, IB, -ONE, - $ AB( 1+IB, I ), LDAB-1, ONE, - $ AB( 1, I+IB ), LDAB-1 ) - END IF -* - IF( I3 > 0 ) THEN -* -* Copy the upper triangle of A31 into the work array. -* - DO 110 JJ = 1, IB - DO 100 II = 1, MIN( JJ, I3 ) - WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 ) - 100 CONTINUE - 110 CONTINUE -* -* Update A31 (in the work array). -* - CALL DTRSM( 'Right', 'Lower', 'Transpose', - $ 'Non-unit', I3, IB, ONE, AB( 1, I ), - $ LDAB-1, WORK, LDWORK ) -* -* Update A32 -* - IF( I2 > 0 ) - $ CALL DGEMM( 'No transpose', 'Transpose', I3, I2, - $ IB, -ONE, WORK, LDWORK, - $ AB( 1+IB, I ), LDAB-1, ONE, - $ AB( 1+KD-IB, I+IB ), LDAB-1 ) -* -* Update A33 -* - CALL DSYRK( 'Lower', 'No Transpose', I3, IB, -ONE, - $ WORK, LDWORK, ONE, AB( 1, I+KD ), - $ LDAB-1 ) -* -* Copy the upper triangle of A31 back into place. -* - DO 130 JJ = 1, IB - DO 120 II = 1, MIN( JJ, I3 ) - AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ ) - 120 CONTINUE - 130 CONTINUE - END IF - END IF - 140 CONTINUE - END IF - END IF - go to 9000 ! My line -* - 150 CONTINUE - go to 9000 ! My line -* -12345 format(5X,'Block ',i8,' of ',i8,'. Factoring rows 1 thru: ',i8,a) - -* End of DPBTRF -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DPBTRF - -! ################################################################################################################################## -! 003 LAPACK_LINEAR_EQN_DPB - - SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBTF2' -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, KD, LDAB, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* DPBTF2 computes the Cholesky factorization of a real symmetric -* positive definite band matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix, U' is the transpose of U, and -* L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of super-diagonals of the matrix A if UPLO = 'U', -* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. -* -* AB (input/output) REAL(DOUBLE) array, dimension (LDAB,N) -* On entry, the upper or lower triangle of the symmetric band -* matrix A, stored in the first KD+1 rows of the array. The -* j-th column of A is stored in the j-th column of the array AB -* as follows: -* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -* -* On exit, if INFO = 0, the triangular factor U or L from the -* Cholesky factorization A = U'*U or A = L*L' of the band -* matrix A, in the same storage format as A. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* N = 6, KD = 2, and UPLO = 'U': -* -* On entry: On exit: -* -* * * a13 a24 a35 a46 * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* -* Similarly, if UPLO = 'L' the format of A is as follows: -* -* On entry: On exit: -* -* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 -* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * -* a31 a42 a53 a64 * * l31 l42 l53 l64 * * -* -* Array elements marked * are not used by the routine. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER i,J, KLD, KN - REAL(DOUBLE) AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N < 0 ) THEN - INFO = -2 - ELSE IF( KD < 0 ) THEN - INFO = -3 - ELSE IF( LDAB < KD+1 ) THEN - INFO = -5 - END IF - IF( INFO /= 0 ) THEN - CALL XERBLA( 'DPBTF2', -INFO ) - go to 9000 ! My line - END IF -* -* Quick return if possible -* - IF( N == 0 ) - & go to 9000 ! My line -* - KLD = MAX( 1, LDAB-1 ) -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - WRITE(SC1,*) - DO 10 J = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j,n,cr13_dpb - ENDIF -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = AB( KD+1, J ) - IF( AJJ <= ZERO ) THEN - GO TO 30 - ENDIF - AJJ = SQRT( AJJ ) - AB( KD+1, J ) = AJJ -* -* Compute elements J+1:J+KN of row J and update the -* trailing submatrix within the band. -* - KN = MIN( KD, N-J ) - IF( KN > 0 ) THEN - CALL DSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD ) - CALL DSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD, - $ AB( KD+1, J+1 ), KLD ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - WRITE(SC1,*) - DO 20 J = 1, N - IF (NOCOUNTS .NE. 'Y') THEN - write(sc1,12345,advance='no') j,n,cr13_dpb - ENDIF -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = AB( 1, J ) - IF( AJJ <= ZERO ) - $ GO TO 30 - AJJ = SQRT( AJJ ) - AB( 1, J ) = AJJ -* -* Compute elements J+1:J+KN of column J and update the -* trailing submatrix within the band. -* - KN = MIN( KD, N-J ) - IF( KN > 0 ) THEN - CALL DSCAL( KN, ONE / AJJ, AB( 2, J ), 1 ) - CALL DSYR( 'Lower', KN, -ONE, AB( 2, J ), 1, - $ AB( 1, J+1 ), KLD ) - END IF - 20 CONTINUE - END IF - go to 9000 ! My line -* - 30 CONTINUE - INFO = J - go to 9000 ! My line -* -12345 format(5x,'DPBTF2: Unblocked code. Factoring row ',i8,' of ',i8,a) - -* End of DPBTF2 -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DPBTF2 - -! ################################################################################################################################## -! 004 LAPACK_LINEAR_EQN_DPB - - SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPOTF2' -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTF2 computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - REAL(DOUBLE) AJJ,dda -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N < 0 ) THEN - INFO = -2 - ELSE IF( LDA < MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO /= 0 ) THEN - CALL XERBLA( 'DPOTF2', -INFO ) - go to 9000 ! My line - END IF -* -* Quick return if possible -* - IF( N == 0 ) - & go to 9000 ! My line -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ <= ZERO ) THEN - AJJ = ONE - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J < N ) THEN - CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) - CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), - $ LDA ) - IF( AJJ <= ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J < N ) THEN - CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) - CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE -* -* End of DPOTF2 -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DPOTF2 - -! ################################################################################################################################## -! 005 LAPACK_LINEAR_EQN_DPB - - SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, - $ IWORK, INFO, itmax, dtbsv_msg ) - -! I added itmax, dtbsv_msg - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBCON' -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - character*1 dtbsv_msg - INTEGER INFO, KD, LDAB, N - REAL(DOUBLE) ANORM, RCOND -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - REAL(DOUBLE) AB( LDAB, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DPBCON estimates the reciprocal of the condition number (in the -* 1-norm) of a real symmetric positive definite band matrix using the -* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF. -* -* An estimate is obtained for norm(inv(A)), and the reciprocal of the -* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangular factor stored in AB; -* = 'L': Lower triangular factor stored in AB. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of superdiagonals of the matrix A if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KD >= 0. -* -* AB (input) REAL(DOUBLE) array, dimension (LDAB,N) -* The triangular factor U or L from the Cholesky factorization -* A = U**T*U or A = L*L**T of the band matrix A, stored in the -* first KD+1 rows of the array. The j-th column of U or L is -* stored in the j-th column of the array AB as follows: -* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; -* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* ANORM (input) REAL(DOUBLE) -* The 1-norm (or infinity-norm) of the symmetric band matrix A. -* -* RCOND (output) REAL(DOUBLE) -* The reciprocal of the condition number of the matrix A, -* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an -* estimate of the 1-norm of inv(A) computed in this routine. -* -* WORK (workspace) REAL(DOUBLE) array, dimension (3*N) -* -* IWORK (workspace) INTEGER array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -! dtbsv_msg (input) CHARACTER -! = 'Y', have subr DTBSV print Fwd, Back pass messages - -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - CHARACTER NORMIN - CHARACTER*48 MODNAM - INTEGER IX, KASE - integer iter_num, itmax - REAL(DOUBLE) AINVNM, SCALE, SCALEL, SCALEU, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N < 0 ) THEN - INFO = -2 - ELSE IF( KD < 0 ) THEN - INFO = -3 - ELSE IF( LDAB < KD+1 ) THEN - INFO = -5 - ELSE IF( ANORM < ZERO ) THEN - INFO = -6 - END IF - IF( INFO /= 0 ) THEN - CALL XERBLA( 'DPBCON', -INFO ) - go to 9000 ! My line - END IF -* -* Quick return if possible -* - RCOND = ZERO - IF( N == 0 ) THEN - RCOND = ONE - go to 9000 ! My line - ELSE IF( ANORM == ZERO ) THEN - go to 9000 ! My line - END IF -* - SMLNUM = DLAMCH( 'Safe minimum' ) -* -* Estimate the 1-norm of the inverse. -* - KASE = 0 - iter_num = 0 - NORMIN = 'N' - 10 CONTINUE - iter_num = iter_num + 1 - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, itmax )! my ITMAX - IF( KASE /= 0 ) THEN - IF( UPPER ) THEN -* -* Multiply by inv(U'). -* - CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, - $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ), - $ INFO, iter_num, dtbsv_msg ) - NORMIN = 'Y' -* -* Multiply by inv(U). -* - CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ), - $ INFO, iter_num, dtbsv_msg ) - ELSE -* -* Multiply by inv(L). -* - CALL DLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, - $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ), - $ INFO, iter_num, dtbsv_msg ) - NORMIN = 'Y' -* -* Multiply by inv(L'). -* - CALL DLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, - $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ), - $ INFO, iter_num, dtbsv_msg ) - END IF -* -* Multiply by 1/SCALE if doing so will not cause overflow. -* - SCALE = SCALEL*SCALEU - IF( SCALE /= ONE ) THEN - IX = IDAMAX( N, WORK, 1 ) - IF( SCALE < ABS( WORK( IX ) )*SMLNUM .OR. SCALE == ZERO ) - $ GO TO 20 - CALL DRSCL( N, SCALE, WORK, 1 ) - END IF - GO TO 10 - END IF -* -* Compute the estimate of the reciprocal condition number. -* - IF( AINVNM /= ZERO ) - $ RCOND = ( ONE / AINVNM ) / ANORM -* - 20 CONTINUE -* - go to 9000 ! My line -* -* End of DPBCON -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DPBCON - -! ################################################################################################################################## -! 006 LAPACK_LINEAR_EQN_DPB - - SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO, - & dtbsv_msg ) ! my addition - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPBTRS' -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - character*1 dtbsv_msg - INTEGER INFO, KD, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - REAL(DOUBLE) AB( LDAB, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DPBTRS solves a system of linear equations A*X = B with a symmetric -* positive definite band matrix A using the Cholesky factorization -* A = U**T*U or A = L*L**T computed by DPBTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangular factor stored in AB; -* = 'L': Lower triangular factor stored in AB. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of superdiagonals of the matrix A if UPLO = 'U', -* or the number of subdiagonals if UPLO = 'L'. KD >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* AB (input) REAL(DOUBLE) array, dimension (LDAB,N) -* The triangular factor U or L from the Cholesky factorization -* A = U**T*U or A = L*L**T of the band matrix A, stored in the -* first KD+1 rows of the array. The j-th column of U or L is -* stored in the j-th column of the array AB as follows: -* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; -* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* B (input/output) REAL(DOUBLE) array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -! dtbsv_msg (input) CHARACTER -! = 'Y', have subr DTBSV print Fwd, Back pass messages - -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N < 0 ) THEN - INFO = -2 - ELSE IF( KD < 0 ) THEN - INFO = -3 - ELSE IF( NRHS < 0 ) THEN - INFO = -4 - ELSE IF( LDAB < KD+1 ) THEN - INFO = -6 - ELSE IF( LDB < MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO /= 0 ) THEN - CALL XERBLA( 'DPBTRS', -INFO ) - go to 9000 ! My line - END IF -* -* Quick return if possible -* - IF( N == 0 .OR. NRHS == 0 ) - & go to 9000 ! My line -* - IF( UPPER ) THEN -* -* Solve A*X = B where A = U'*U. -* - DO 10 J = 1, NRHS - write(f06,*) 'In DPBTRS calling DTBSV with j = ',j -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB, - $ LDAB, B( 1, J ), 1, dtbsv_msg ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB, - $ LDAB, B( 1, J ), 1, dtbsv_msg ) - 10 CONTINUE - ELSE -* -* Solve A*X = B where A = L*L'. -* - DO 20 J = 1, NRHS -* -* Solve L*X = B, overwriting B with X. -* - CALL DTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB, - $ LDAB, B( 1, J ), 1, dtbsv_msg ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB, - $ LDAB, B( 1, J ), 1, dtbsv_msg ) - 20 CONTINUE - END IF -* - go to 9000 ! My line -* -* End of DPBTRS -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** -98711 FORMAT(' ido = ',I3,', ipntr(1) = ',I8,', ipntr(2) = ',I8) - -98712 FORMAT(' I, AB, B = ',I8,2(1ES15.6)) - - END SUBROUTINE DPBTRS - -! ################################################################################################################################## -! 007 LAPACK_LINEAR_EQN_DPB - - SUBROUTINE DPTTRF_MYSTRAN( N, D, E, INFO ) - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DPTTRF' - -! This is my mod of LAPACK subr DPTTRF. I have changed the statements: - -! IF( D( I ).LE.ZERO ) THEN -! to -! IF( D( I ).EQ.ZERO ) THEN - -! in order to allow the subr to get the LDL decomp when diag elements -! are neqative. I need this in LINK4 for subr EST_NUMBER_OF_EIGENS -! which needs a count of the number of diag terms < 0 in order to -! estimate the number of eigens less than a specified value. - -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) D( * ), E( * ) -* .. -* -* Purpose -* ======= -* -* DPTTRF computes the L*D*L' factorization of a real symmetric -* positive definite tridiagonal matrix A. The factorization may also -* be regarded as having the form A = U'*D*U. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the tridiagonal matrix -* A. On exit, the n diagonal elements of the diagonal matrix -* D from the L*D*L' factorization of A. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix A. On exit, the (n-1) subdiagonal elements of the -* unit bidiagonal factor L from the L*D*L' factorization of A. -* E can also be regarded as the superdiagonal of the unit -* bidiagonal factor U from the U'*D*U factorization of A. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite; if k < N, the factorization could not -* be completed, while if k = N, the factorization was -* completed, but D(N) <= 0. -** -* .. Parameters .. - REAL(DOUBLE) ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, I4 - REAL(DOUBLE) EI -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'DPTTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Compute the L*D*L' (or U'*D*U) factorization of A. -* - I4 = MOD( N-1, 4 ) - DO 10 I = 1, I4 - IF( D( I ).EQ.ZERO ) THEN - INFO = I - GO TO 30 - END IF - EI = E( I ) - E( I ) = EI / D( I ) - D( I+1 ) = D( I+1 ) - E( I )*EI - 10 CONTINUE -* - DO 20 I = I4 + 1, N - 4, 4 -* -* Drop out of the loop if d(i) <= 0: the matrix is not positive -* definite. -* - IF( D( I ).EQ.ZERO ) THEN - INFO = I - GO TO 30 - END IF -* -* Solve for e(i) and d(i+1). -* - EI = E( I ) - E( I ) = EI / D( I ) - D( I+1 ) = D( I+1 ) - E( I )*EI -* - IF( D( I ).EQ.ZERO ) THEN - INFO = I + 1 - GO TO 30 - END IF -* -* Solve for e(i+1) and d(i+2). -* - EI = E( I+1 ) - E( I+1 ) = EI / D( I+1 ) - D( I+2 ) = D( I+2 ) - E( I+1 )*EI -* - IF( D( I ).EQ.ZERO ) THEN - INFO = I + 2 - GO TO 30 - END IF -* -* Solve for e(i+2) and d(i+3). -* - EI = E( I+2 ) - E( I+2 ) = EI / D( I+2 ) - D( I+3 ) = D( I+3 ) - E( I+2 )*EI -* - IF( D( I ).EQ.ZERO ) THEN - INFO = I + 3 - GO TO 30 - END IF -* -* Solve for e(i+3) and d(i+4). -* - EI = E( I+3 ) - E( I+3 ) = EI / D( I+3 ) - D( I+4 ) = D( I+4 ) - E( I+3 )*EI - 20 CONTINUE -* -* Check d(n) for positive definiteness. -* - IF( D( N ).LE.ZERO ) - $ INFO = N -* - 30 CONTINUE - RETURN -* -* End of DPTTRF -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DPTTRF_MYSTRAN - -! ################################################################################################################################# -! 008 LAPACK_LINEAR_EQN_DPB - - SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSYTF2' -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DSYTF2 computes the factorization of a real symmetric matrix A using -* the Bunch-Kaufman diagonal pivoting method: -* -* A = U*D*U' or A = L*D*L' -* -* where U (or L) is a product of permutation and unit upper (lower) -* triangular matrices, U' is the transpose of U, and D is symmetric and -* block diagonal with 1-by-1 and 2-by-2 diagonal blocks. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n-by-n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n-by-n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, the block diagonal matrix D and the multipliers used -* to obtain the factor U or L (see below for further details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D. -* If IPIV(k) > 0, then rows and columns k and IPIV(k) were -* interchanged and D(k,k) is a 1-by-1 diagonal block. -* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, D(k,k) is exactly zero. The factorization -* has been completed, but the block diagonal matrix D is -* exactly singular, and division by zero will occur if it -* is used to solve a system of equations. -* -* Further Details -* =============== -* -* 09-29-06 - patch from -* Bobby Cheng, MathWorks -* -* Replace l.204 and l.372 -* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* by -* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN -* -* 01-01-96 - Based on modifications by -* J. Lewis, Boeing Computer Services Company -* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services -* Company -* -* If UPLO = 'U', then A = U*D*U', where -* U = P(n)*U(n)* ... *P(k)U(k)* ..., -* i.e., U is a product of terms P(k)*U(k), where k decreases from n to -* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I v 0 ) k-s -* U(k) = ( 0 I 0 ) s -* ( 0 0 I ) n-k -* k-s s n-k -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). -* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), -* and A(k,k), and v overwrites A(1:k-2,k-1:k). -* -* If UPLO = 'L', then A = L*D*L', where -* L = P(1)*L(1)* ... *P(k)*L(k)* ..., -* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to -* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I 0 0 ) k-1 -* L(k) = ( 0 I 0 ) s -* ( 0 v I ) n-k-s+1 -* k-1 s n-k-s+1 -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). -* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), -* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION EIGHT, SEVTEN - PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP - DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, - $ ROWMAX, T, WK, WKM1, WKP1 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTF2', -INFO ) - RETURN - END IF -* -* Initialize ALPHA for use in choosing pivot block size. -* - ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT -* - IF( UPPER ) THEN -* -* Factorize A as U*D*U' using the upper triangle of A -* -* K is the main loop index, decreasing from N to 1 in steps of -* 1 or 2 -* - K = N - 10 CONTINUE -* -* If K < 1, exit from loop -* - IF( K.LT.1 ) - $ GO TO 70 - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( A( K, K ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.GT.1 ) THEN - IMAX = IDAMAX( K-1, A( 1, K ), 1 ) - COLMAX = ABS( A( IMAX, K ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN -* -* Column K is zero or contains a NaN: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) - ROWMAX = ABS( A( IMAX, JMAX ) ) - IF( IMAX.GT.1 ) THEN - JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX - ELSE -* -* interchange rows and columns K-1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K - KSTEP + 1 - IF( KP.NE.KK ) THEN -* -* Interchange rows and columns KK and KP in the leading -* submatrix A(1:k,1:k) -* - CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) - CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), - $ LDA ) - T = A( KK, KK ) - A( KK, KK ) = A( KP, KP ) - A( KP, KP ) = T - IF( KSTEP.EQ.2 ) THEN - T = A( K-1, K ) - A( K-1, K ) = A( KP, K ) - A( KP, K ) = T - END IF - END IF -* -* Update the leading submatrix -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k now holds -* -* W(k) = U(k)*D(k) -* -* where U(k) is the k-th column of U -* -* Perform a rank-1 update of A(1:k-1,1:k-1) as -* -* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' -* - R1 = ONE / A( K, K ) - CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) -* -* Store U(k) in column k -* - CALL DSCAL( K-1, R1, A( 1, K ), 1 ) - ELSE -* -* 2-by-2 pivot block D(k): columns k and k-1 now hold -* -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) -* -* where U(k) and U(k-1) are the k-th and (k-1)-th columns -* of U -* -* Perform a rank-2 update of A(1:k-2,1:k-2) as -* -* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' -* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' -* - IF( K.GT.2 ) THEN -* - D12 = A( K-1, K ) - D22 = A( K-1, K-1 ) / D12 - D11 = A( K, K ) / D12 - T = ONE / ( D11*D22-ONE ) - D12 = T / D12 -* - DO 30 J = K - 2, 1, -1 - WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) - WK = D12*( D22*A( J, K )-A( J, K-1 ) ) - DO 20 I = J, 1, -1 - A( I, J ) = A( I, J ) - A( I, K )*WK - - $ A( I, K-1 )*WKM1 - 20 CONTINUE - A( J, K ) = WK - A( J, K-1 ) = WKM1 - 30 CONTINUE -* - END IF -* - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K-1 ) = -KP - END IF -* -* Decrease K and return to the start of the main loop -* - K = K - KSTEP - GO TO 10 -* - ELSE -* -* Factorize A as L*D*L' using the lower triangle of A -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2 -* - K = 1 - 40 CONTINUE -* -* If K > N, exit from loop -* - IF( K.GT.N ) - $ GO TO 70 - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( A( K, K ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.LT.N ) THEN - IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) - COLMAX = ABS( A( IMAX, K ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN -* -* Column K is zero or contains a NaN: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) - ROWMAX = ABS( A( IMAX, JMAX ) ) - IF( IMAX.LT.N ) THEN - JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX - ELSE -* -* interchange rows and columns K+1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K + KSTEP - 1 - IF( KP.NE.KK ) THEN -* -* Interchange rows and columns KK and KP in the trailing -* submatrix A(k:n,k:n) -* - IF( KP.LT.N ) - $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) - CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), - $ LDA ) - T = A( KK, KK ) - A( KK, KK ) = A( KP, KP ) - A( KP, KP ) = T - IF( KSTEP.EQ.2 ) THEN - T = A( K+1, K ) - A( K+1, K ) = A( KP, K ) - A( KP, K ) = T - END IF - END IF -* -* Update the trailing submatrix -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k now holds -* -* W(k) = L(k)*D(k) -* -* where L(k) is the k-th column of L -* - IF( K.LT.N ) THEN -* -* Perform a rank-1 update of A(k+1:n,k+1:n) as -* -* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' -* - D11 = ONE / A( K, K ) - CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, - $ A( K+1, K+1 ), LDA ) -* -* Store L(k) in column K -* - CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) - END IF - ELSE -* -* 2-by-2 pivot block D(k) -* - IF( K.LT.N-1 ) THEN -* -* Perform a rank-2 update of A(k+2:n,k+2:n) as -* -* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))' -* -* where L(k) and L(k+1) are the k-th and (k+1)-th -* columns of L -* - D21 = A( K+1, K ) - D11 = A( K+1, K+1 ) / D21 - D22 = A( K, K ) / D21 - T = ONE / ( D11*D22-ONE ) - D21 = T / D21 -* - DO 60 J = K + 2, N -* - WK = D21*( D11*A( J, K )-A( J, K+1 ) ) - WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) -* - DO 50 I = J, N - A( I, J ) = A( I, J ) - A( I, K )*WK - - $ A( I, K+1 )*WKP1 - 50 CONTINUE -* - A( J, K ) = WK - A( J, K+1 ) = WKP1 -* - 60 CONTINUE - END IF - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K+1 ) = -KP - END IF -* -* Increase K and return to the start of the main loop -* - K = K + KSTEP - GO TO 40 -* - END IF -* - 70 CONTINUE -* - RETURN -* -* End of DSYTF2 -* -! ********************************************************************************************************************************** - 9000 continue ! My lines - - RETURN - -! ********************************************************************************************************************************** - - END SUBROUTINE DSYTF2 - - END MODULE LAPACK_LIN_EQN_DPB diff --git a/Source/Modules/LAPACK/LAPACK_MISCEL.f b/Source/Modules/LAPACK/LAPACK_MISCEL.f deleted file mode 100644 index d298926f..00000000 --- a/Source/Modules/LAPACK/LAPACK_MISCEL.f +++ /dev/null @@ -1,362 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_MISCEL - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE SCONTR, ONLY : BLNK_SUB_NAM - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & TSEC - - USE LAPACK_BLAS_AUX - USE LAPACK_LIN_EQN_DPB - - USE OURTIM_Interface - -! This is a set of LAPACK routines that are used in several other modules but are not BLAS or auxiliary routines -! The routines included herein are: - -! DSTERF: computes all eigenvalues of a symmetric tridiagonal matrix using the Pal-Walker-Kahan variant of the QL or QR alg. - -! DSTEQR: computes all eigenvalues and, optionally, eigenvectors of a sym tridiag matrix using the implicit QL or QR method. - -! DSTEV : computes all eigenvalues and, optionally, eigenvectors of a real symmetric tridiagonal matrix A - -! DTRTRS: solves a triangular system of the form - -! A * X = B or A**T * X = B, - -! where A is a triangular matrix of order N, and B is an N-by-NRHS matrix. A check is made to verify A is nonsingular. - - - CONTAINS - -! ################################################################################################################################## -! 003 LAPACK_MISCEL - - SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSTERF' -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INFO, LDZ, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) -* .. -* -* Purpose -* ======= -* -* DSTEV computes all eigenvalues and, optionally, eigenvectors of a -* real symmetric tridiagonal matrix A. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* N (input) INTEGER -* The order of the matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the tridiagonal matrix -* A. -* On exit, if INFO = 0, the eigenvalues in ascending order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N-1) -* On entry, the (n-1) subdiagonal elements of the tridiagonal -* matrix A, stored in elements 1 to N-1 of E. -* On exit, the contents of E are destroyed. -* -* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) -* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal -* eigenvectors of the matrix A, with the i-th column of Z -* holding the eigenvector associated with D(i). -* If JOBZ = 'N', then Z is not referenced. -* -* LDZ (input) INTEGER -* The leading dimension of the array Z. LDZ >= 1, and if -* JOBZ = 'V', LDZ >= max(1,N). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) -* If JOBZ = 'N', WORK is not referenced. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm failed to converge; i -* off-diagonal elements of E did not converge to zero. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL WANTZ - INTEGER IMAX, ISCALE - DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, - $ TNRM -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANST - EXTERNAL LSAME, DLAMCH, DLANST -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSTEQR, DSTERF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC SQRT -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN - INFO = -6 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSTEV ', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( N.EQ.1 ) THEN - IF( WANTZ ) - $ Z( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ISCALE = 0 - TNRM = DLANST( 'M', N, D, E ) - IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / TNRM - ELSE IF( TNRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / TNRM - END IF - IF( ISCALE.EQ.1 ) THEN - CALL DSCAL( N, SIGMA, D, 1 ) - CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) - END IF -* -* For eigenvalues only, call DSTERF. For eigenvalues and -* eigenvectors, call DSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, D, E, INFO ) - ELSE - CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, D, 1 ) - END IF -* - RETURN -* -* End of DSTEV -* - END SUBROUTINE DSTEV - -! ################################################################################################################################## -! 004 LAPACK_MISCEL - - SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, - $ INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSTERF' -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER DIAG, TRANS, UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRTRS solves a triangular system of the form -* -* A * X = B or A**T * X = B, -* -* where A is a triangular matrix of order N, and B is an N-by-NRHS -* matrix. A check is made to verify that A is nonsingular. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T * X = B (Transpose) -* = 'C': A**H * X = B (Conjugate transpose = Transpose) -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The triangular matrix A. If UPLO = 'U', the leading N-by-N -* upper triangular part of the array A contains the upper -* triangular matrix, and the strictly lower triangular part of -* A is not referenced. If UPLO = 'L', the leading N-by-N lower -* triangular part of the array A contains the lower triangular -* matrix, and the strictly upper triangular part of A is not -* referenced. If DIAG = 'U', the diagonal elements of A are -* also not referenced and are assumed to be 1. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, if INFO = 0, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the i-th diagonal element of A is zero, -* indicating that the matrix is singular and the solutions -* X have not been computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - INFO = 0 - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. - $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - END IF - INFO = 0 -* -* Solve A * x = b or A' * x = b. -* - CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, - $ LDB ) -* - RETURN -* -* End of DTRTRS -* - END SUBROUTINE DTRTRS - - END MODULE LAPACK_MISCEL - diff --git a/Source/Modules/LAPACK/LAPACK_STD_EIG_1.f b/Source/Modules/LAPACK/LAPACK_STD_EIG_1.f deleted file mode 100644 index 28ed0fae..00000000 --- a/Source/Modules/LAPACK/LAPACK_STD_EIG_1.f +++ /dev/null @@ -1,718 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_STD_EIG_1 - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06 - USE SCONTR, ONLY : LINKNO, BLNK_SUB_NAM - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & SFRAC, STIME, TSEC - USE LAPACK_BLAS_AUX - USE LAPACK_MISCEL ! This contains DSTEQR, used in this module - - USE OURTIM_Interface - USE OUTA_HERE_Interface - - CHARACTER(44*BYTE), PRIVATE :: MODNAM ! Name to write to screen to describe module being run. - -! This is a set of LAPACK routines for solving for all of the eigenvalues -! and, possibly, all eigenvectors of: - -! Ax = (Lambda)x (1) - -! where A is real and symmetric. - -! This module contains LAPACK subroutines described below: - -! DSYEV : Main driver for solving (1) for eigenvalues and eigenvectors - -! DSYEV calls the LAPACK subroutines included herein and described below to do the main computations. - -! DSYTRD: To reduce A to tridiagonal form, and -! DSTERF: To calc eigenvalues if NO eigenvectors are sought, or -! NOTE: DSTEQR is not in this module, it is in module LAPACK_MISCEL, since it is used in several modules -! DORGTR: To generate orthogonal matrices - -! DSYEV also uses - -! DSTEQR: to compute all eigenvalues and all eigenvectors of the tridiagonal matrix (if eigenvectors are requested). -! NOTE: DSTEQR is not in this module, it is in module LAPACK_MISCEL, since it is used in several other modules - -! In addition, other LAPACK procedures are called from module LAPACK_BLAS_AUX_1 - - CONTAINS - -! ################################################################################################################################## -! 001 LAPACK_STD_EIG_1 - - SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSYEV' -* -* -- LAPACK driver routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER JOBZ, UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), W( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSYEV computes all eigenvalues and, optionally, eigenvectors of a -* real symmetric matrix A. -* -* Arguments -* ========= -* -* JOBZ (input) CHARACTER*1 -* = 'N': Compute eigenvalues only; -* = 'V': Compute eigenvalues and eigenvectors. -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA, N) -* On entry, the symmetric matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of A contains the -* upper triangular part of the matrix A. If UPLO = 'L', -* the leading N-by-N lower triangular part of A contains -* the lower triangular part of the matrix A. -* On exit, if JOBZ = 'V', then if INFO = 0, A contains the -* orthonormal eigenvectors of the matrix A. -* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') -* or the upper triangle (if UPLO='U') of A, including the -* diagonal, is destroyed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* W (output) REAL(DOUBLE) array, dimension (N) -* If INFO = 0, the eigenvalues in ascending order. -* -* WORK (workspace/output) REAL(DOUBLE) array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,3*N-1). -* For optimal efficiency, LWORK >= (NB+2)*N, -* where NB is the blocksize for DSYTRD returned by ILAENV. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm failed to converge; i -* off-diagonal elements of an intermediate tridiagonal -* form did not converge to zero. -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL LOWER, WANTZ - INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, - $ LLWORK, LOPT - REAL(DOUBLE) ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, - $ SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - - INTEGER ILAENV - EXTERNAL ILAENV - - REAL(DOUBLE) DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - WANTZ = LSAME( JOBZ, 'V' ) - LOWER = LSAME( UPLO, 'L' ) -* - INFO = 0 - IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) ) THEN - INFO = -8 - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYEV ', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( N.EQ.1 ) THEN - W( 1 ) = A( 1, 1 ) - WORK( 1 ) = 3 - IF( WANTZ ) - $ A( 1, 1 ) = ONE - RETURN - END IF -* -* Get machine constants. -* - SAFMIN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Precision' ) - SMLNUM = SAFMIN / EPS - BIGNUM = ONE / SMLNUM - RMIN = SQRT( SMLNUM ) - RMAX = SQRT( BIGNUM ) -* -* Scale matrix to allowable range, if necessary. -* - ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) - ISCALE = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN - ISCALE = 1 - SIGMA = RMIN / ANRM - ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 - SIGMA = RMAX / ANRM - END IF - IF( ISCALE.EQ.1 ) - $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) -* -* Call DSYTRD to reduce symmetric matrix to tridiagonal form. -* - INDE = 1 - INDTAU = INDE + N - INDWRK = INDTAU + N - LLWORK = LWORK - INDWRK + 1 - CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), - $ WORK( INDWRK ), LLWORK, IINFO ) - LOPT = 2*N + WORK( INDWRK ) -* -* For eigenvalues only, call DSTERF. For eigenvectors, first call -* DORGTR to generate the orthogonal matrix, then call DSTEQR. -* - IF( .NOT.WANTZ ) THEN - CALL DSTERF( N, W, WORK( INDE ), INFO ) - ELSE - CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), - $ LLWORK, IINFO ) - CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), - $ INFO ) - END IF -* -* If matrix was scaled, then rescale eigenvalues appropriately. -* - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = N - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF -* -* Set WORK(1) to optimal workspace size. -* - WORK( 1 ) = MAX( 3*N-1, LOPT ) -* - - RETURN -* -* End of DSYEV -* - END SUBROUTINE DSYEV - -! ################################################################################################################################## -! 002 LAPACK_STD_EIG_1 - - SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DSYTRD' -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), D( * ), E( * ), TAU( * ), - $ WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSYTRD reduces a real symmetric matrix A to real symmetric -* tridiagonal form T by an orthogonal similarity transformation: -* Q**T * A * Q = T. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* On exit, if UPLO = 'U', the diagonal and first superdiagonal -* of A are overwritten by the corresponding elements of the -* tridiagonal matrix T, and the elements above the first -* superdiagonal, with the array TAU, represent the orthogonal -* matrix Q as a product of elementary reflectors; if UPLO -* = 'L', the diagonal and first subdiagonal of A are over- -* written by the corresponding elements of the tridiagonal -* matrix T, and the elements below the first subdiagonal, with -* the array TAU, represent the orthogonal matrix Q as a product -* of elementary reflectors. See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* D (output) REAL(DOUBLE) array, dimension (N) -* The diagonal elements of the tridiagonal matrix T: -* D(i) = A(i,i). -* -* E (output) REAL(DOUBLE) array, dimension (N-1) -* The off-diagonal elements of the tridiagonal matrix T: -* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. -* -* TAU (output) REAL(DOUBLE) array, dimension (N-1) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) REAL(DOUBLE) array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= 1. -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* If UPLO = 'U', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(n-1) . . . H(2) H(1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in -* A(1:i-1,i+1), and tau in TAU(i). -* -* If UPLO = 'L', the matrix Q is represented as a product of elementary -* reflectors -* -* Q = H(1) H(2) . . . H(n-1). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), -* and tau in TAU(i). -* -* The contents of A on exit are illustrated by the following examples -* with n = 5: -* -* if UPLO = 'U': if UPLO = 'L': -* -* ( d e v2 v3 v4 ) ( d ) -* ( d e v3 v4 ) ( e d ) -* ( d e v4 ) ( v1 e d ) -* ( d e ) ( v1 v2 e d ) -* ( d ) ( v1 v2 v3 e d ) -* -* where d and e denote diagonal and off-diagonal elements of T, and vi -* denotes an element of the vector defining H(i). -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IINFO, IWS, J, KK, LDWORK, NB, NBMIN, NX -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. - -* -* Test the input parameters -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.1 ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSYTRD', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - NX = N - IWS = 1 - IF( NB.GT.1 .AND. NB.LT.N ) THEN -* -* Determine when to cross over from blocked to unblocked code -* (last block is always handled by unblocked code). -* - NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) - IF( NX.LT.N ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: determine the -* minimum value of NB, and reduce NB or force use of -* unblocked code by setting NX = N. -* - NB = MAX( LWORK / LDWORK, 1 ) - NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) - IF( NB.LT.NBMIN ) - $ NX = N - END IF - ELSE - NX = N - END IF - ELSE - NB = 1 - END IF -* - IF( UPPER ) THEN -* -* Reduce the upper triangle of A. -* Columns 1:kk are handled by the unblocked method. -* - KK = N - ( ( N-NX+NB-1 ) / NB )*NB - DO 20 I = N - NB + 1, KK + 1, -NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, - $ LDWORK ) -* -* Update the unreduced submatrix A(1:i-1,1:i-1), using an -* update of the form: A := A - V*W' - W*V' -* - CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), - $ LDA, WORK, LDWORK, ONE, A, LDA ) -* -* Copy superdiagonal elements back into A, and diagonal -* elements into D -* - DO 10 J = I, I + NB - 1 - A( J-1, J ) = E( J-1 ) - D( J ) = A( J, J ) - 10 CONTINUE - 20 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) - ELSE -* -* Reduce the lower triangle of A -* - DO 40 I = 1, N - NX, NB -* -* Reduce columns i:i+nb-1 to tridiagonal form and form the -* matrix W which is needed to update the unreduced part of -* the matrix -* - CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), - $ TAU( I ), WORK, LDWORK ) -* -* Update the unreduced submatrix A(i+ib:n,i+ib:n), using -* an update of the form: A := A - V*W' - W*V' -* - CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, - $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, - $ A( I+NB, I+NB ), LDA ) -* -* Copy subdiagonal elements back into A, and diagonal -* elements into D -* - DO 30 J = I, I + NB - 1 - A( J+1, J ) = E( J ) - D( J ) = A( J, J ) - 30 CONTINUE - 40 CONTINUE -* -* Use unblocked code to reduce the last or only block -* - CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAU( I ), IINFO ) - END IF -* - WORK( 1 ) = IWS - - RETURN -* -* End of DSYTRD -* - END SUBROUTINE DSYTRD - -! ################################################################################################################################## -! 003 LAPACK_STD_EIG_1 - - SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: subr_name = 'DORGTR' -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - REAL(DOUBLE) A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORGTR generates a real orthogonal matrix Q which is defined as the -* product of n-1 elementary reflectors of order N, as returned by -* DSYTRD: -* -* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), -* -* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A contains elementary reflectors -* from DSYTRD; -* = 'L': Lower triangle of A contains elementary reflectors -* from DSYTRD. -* -* N (input) INTEGER -* The order of the matrix Q. N >= 0. -* -* A (input/output) REAL(DOUBLE) array, dimension (LDA,N) -* On entry, the vectors which define the elementary reflectors, -* as returned by DSYTRD. -* On exit, the N-by-N orthogonal matrix Q. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* TAU (input) REAL(DOUBLE) array, dimension (N-1) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DSYTRD. -* -* WORK (workspace/output) REAL(DOUBLE) array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N-1). -* For optimum performance LWORK >= (N-1)*NB, where NB is -* the optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL(DOUBLE) ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IINFO, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. - -* -* Test the input arguments -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N-1 ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGTR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( UPPER ) THEN -* -* Q was determined by a call to DSYTRD with UPLO = 'U' -* -* Shift the vectors which define the elementary reflectors one -* column to the left, and set the last row and column of Q to -* those of the unit matrix -* - DO 20 J = 1, N - 1 - DO 10 I = 1, J - 1 - A( I, J ) = A( I, J+1 ) - 10 CONTINUE - A( N, J ) = ZERO - 20 CONTINUE - DO 30 I = 1, N - 1 - A( I, N ) = ZERO - 30 CONTINUE - A( N, N ) = ONE -* -* Generate Q(1:n-1,1:n-1) -* - CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* Q was determined by a call to DSYTRD with UPLO = 'L'. -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q to -* those of the unit matrix -* - DO 50 J = N, 2, -1 - A( 1, J ) = ZERO - DO 40 I = J + 1, N - A( I, J ) = A( I, J-1 ) - 40 CONTINUE - 50 CONTINUE - A( 1, 1 ) = ONE - DO 60 I = 2, N - A( I, 1 ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Generate Q(2:n,2:n) -* - CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - - RETURN -* -* End of DORGTR -* - END SUBROUTINE DORGTR - - END MODULE LAPACK_STD_EIG_1 diff --git a/Source/Modules/LAPACK/LAPACK_SYM_MAT_INV.f b/Source/Modules/LAPACK/LAPACK_SYM_MAT_INV.f deleted file mode 100644 index 9f942c4e..00000000 --- a/Source/Modules/LAPACK/LAPACK_SYM_MAT_INV.f +++ /dev/null @@ -1,762 +0,0 @@ -! ################################################################################################################################## - - MODULE LAPACK_SYM_MAT_INV - - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE SCONTR, ONLY : BLNK_SUB_NAM - USE TIMDAT, ONLY : HOUR, MINUTE, SEC, - & TSEC - - USE LAPACK_BLAS_AUX - USE LAPACK_LIN_EQN_DPB ! Subr DPOTF2 - - USE OURTIM_Interface - -! This is a set of LAPACK routines that are used in inverting symmetric matrices (not band matrices) - - CONTAINS - -! ################################################################################################################################## -! 001 LAPACK_SYM_MAT_INV - - SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRF computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U**T * U, if UPLO = 'U', or -* A = L * L**T, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - - INTEGER ILAENV - EXTERNAL ILAENV - -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL DPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, - $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), - $ LDA, ONE, A( J, J+JB ), LDA ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, - $ A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), - $ LDA, ONE, A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-J-JB+1, JB, ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of DPOTRF -* - END SUBROUTINE DPOTRF - -! ################################################################################################################################## -! 002 LAPACK_SYM_MAT_INV - - SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRI computes the inverse of a real symmetric positive definite -* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T -* computed by DPOTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T, as computed by -* DPOTRF. -* On exit, the upper or lower triangle of the (symmetric) -* inverse of A, overwriting the input factor U or L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the (i,i) element of the factor U or L is -* zero, and the inverse could not be computed. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Invert the triangular Cholesky factor U or L. -* - CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* -* Form inv(U)*inv(U)' or inv(L)'*inv(L). -* - CALL DLAUUM( UPLO, N, A, LDA, INFO ) -* - RETURN -* -* End of DPOTRI -* - END SUBROUTINE DPOTRI - -! ################################################################################################################################## -! 003 LAPACK_SYM_MAT_INV - - SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLAUUM computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the blocked form of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME - - INTEGER ILAENV - EXTERNAL ILAENV - -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAUUM', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), - $ LDA ) - CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL DGEMM( 'No transpose', 'Transpose', I-1, IB, - $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, - $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) - CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB, - $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) - CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No transpose', IB, I-1, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) - CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE, - $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF -* - RETURN -* -* End of DLAUUM -* - END SUBROUTINE DLAUUM - -! ################################################################################################################################## -! 005 LAPACK_SYM_MAT_INV - - SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLAUU2 computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the unblocked form of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - DOUBLE PRECISION AII -* .. -* .. External Functions .. - - LOGICAL LSAME - EXTERNAL LSAME - -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAUU2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 ) - ELSE - CALL DSCAL( I, AII, A( 1, I ), 1 ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, AII, A( I, 1 ), LDA ) - ELSE - CALL DSCAL( I, AII, A( I, 1 ), LDA ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DLAUU2 -* - END SUBROUTINE DLAUU2 - -! ################################################################################################################################## -! 006 LAPACK_SYM_MAT_INV - - SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTI2 computes the inverse of a real upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DTRTI2 -* - END SUBROUTINE DTRTI2 - - END MODULE LAPACK_SYM_MAT_INV - diff --git a/Source/Modules/MYSTRAN_LAPACK_EXT/MYSTRAN_LAPACK_EXT.f90 b/Source/Modules/MYSTRAN_LAPACK_EXT/MYSTRAN_LAPACK_EXT.f90 new file mode 100644 index 00000000..2d464fa9 --- /dev/null +++ b/Source/Modules/MYSTRAN_LAPACK_EXT/MYSTRAN_LAPACK_EXT.f90 @@ -0,0 +1,931 @@ +! ################################################################################################################################## +! Begin MIT license text. +! _______________________________________________________________________________________________________ + +! Copyright 2022 Dr William R Case, Jr (mystransolver@gmail.com) + +! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and +! associated documentation files (the "Software"), to deal in the Software without restriction, including +! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to +! the following conditions: + +! The above copyright notice and this permission notice shall be included in all copies or substantial +! portions of the Software and documentation. + +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. +! _______________________________________________________________________________________________________ + +! End MIT license text. + +! ################################################################################################################################## +! +! MYSTRAN_LAPACK_EXT +! +! Salvaged MYSTRAN-specific LAPACK extensions. These routines have +! mathematical deviations from the corresponding upstream LAPACK +! reference implementations and must therefore stay compiled into +! MYSTRAN regardless of which BLAS+LAPACK provider is being linked. +! +! Every other routine that used to live under Source/Modules/LAPACK has +! been removed; consumers now call standard LAPACK directly (resolved +! at link time against the chosen provider). +! +! Members: +! DPTTRF_MYSTRAN Modified DPTTRF: tests D(I) == 0 instead +! of D(I) <= 0, so the L*D*L^T factorisation +! is produced even with negative diagonal +! entries. Required by EST_NUMBER_OF_EIGENS +! (LINK4) which counts negative diagonals +! to bound the eigenvalue spectrum. +! +! DSBGVX_GIV_MGIV Renamed DSBGVX. Adds three output +! arguments (mlam / eig_num / mvec) and +! accepts a `method` selector to drive +! the GIV / MGIV eigensolvers. Calls +! DSTEBZ_MYSTRAN below. +! +! DSTEBZ_MYSTRAN Renamed DSTEBZ. Produces two extra +! output integers (lowest_mode_num, +! highest_mode_num) needed by +! DSBGVX_GIV_MGIV to populate eig_num. +! No other algorithmic deviation. +! +! EIGENVALUE_CONVERGENCE_FAILURE +! MYSTRAN-specific helper used by +! DSBGVX_GIV_MGIV to surface DSTEBZ +! convergence failures through MYSTRAN's +! error-reporting infrastructure. +! +! ################################################################################################################################## + + MODULE MYSTRAN_LAPACK_EXT + + USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE + USE IOUNT1, ONLY : ERR, F06 + USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR, SOL_NAME + + USE OUTA_HERE_Interface + USE LINK_MESSAGE_Interface + + IMPLICIT NONE + + CONTAINS + +! ################################################################################################################################## +! DPTTRF_MYSTRAN + + SUBROUTINE DPTTRF_MYSTRAN( N, D, E, INFO ) + +! This is a MYSTRAN-specific modification of LAPACK subroutine DPTTRF. +! The original singularity test +! IF( D( I ).LE.ZERO ) THEN +! has been replaced with +! IF( D( I ).EQ.ZERO ) THEN +! so that the L*D*L^T decomposition is produced even when diagonal +! elements are negative. EST_NUMBER_OF_EIGENS in LINK4 needs the +! number of negative diagonals after factorisation to estimate the +! number of eigenvalues below a given shift. + +! .. Scalar Arguments .. + INTEGER INFO, N +! .. +! .. Array Arguments .. + REAL(DOUBLE) D( * ), E( * ) +! .. +! .. Parameters .. + REAL(DOUBLE) ZERO + PARAMETER ( ZERO = 0.0D+0 ) +! .. +! .. Local Scalars .. + INTEGER I, I4 + REAL(DOUBLE) EI +! .. +! .. External Subroutines .. + EXTERNAL XERBLA +! .. +! .. Intrinsic Functions .. + INTRINSIC MOD +! .. +! .. Executable Statements .. + + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DPTTRF', -INFO ) + RETURN + END IF + + IF( N.EQ.0 ) RETURN + + I4 = MOD( N-1, 4 ) + DO 10 I = 1, I4 + IF( D( I ).EQ.ZERO ) THEN + INFO = I + GO TO 30 + END IF + EI = E( I ) + E( I ) = EI / D( I ) + D( I+1 ) = D( I+1 ) - E( I )*EI + 10 CONTINUE + + DO 20 I = I4 + 1, N - 4, 4 + IF( D( I ).EQ.ZERO ) THEN + INFO = I + GO TO 30 + END IF + EI = E( I ) + E( I ) = EI / D( I ) + D( I+1 ) = D( I+1 ) - E( I )*EI + + IF( D( I ).EQ.ZERO ) THEN + INFO = I + 1 + GO TO 30 + END IF + EI = E( I+1 ) + E( I+1 ) = EI / D( I+1 ) + D( I+2 ) = D( I+2 ) - E( I+1 )*EI + + IF( D( I ).EQ.ZERO ) THEN + INFO = I + 2 + GO TO 30 + END IF + EI = E( I+2 ) + E( I+2 ) = EI / D( I+2 ) + D( I+3 ) = D( I+3 ) - E( I+2 )*EI + + IF( D( I ).EQ.ZERO ) THEN + INFO = I + 3 + GO TO 30 + END IF + EI = E( I+3 ) + E( I+3 ) = EI / D( I+3 ) + D( I+4 ) = D( I+4 ) - E( I+3 )*EI + 20 CONTINUE + + IF( D( N ).LE.ZERO ) INFO = N + + 30 CONTINUE + RETURN + + END SUBROUTINE DPTTRF_MYSTRAN + +! ################################################################################################################################## +! DSBGVX_GIV_MGIV +! +! MYSTRAN-specific driver: thin wrapper around the same algorithm as +! upstream LAPACK DSBGVX, but augmented with three extra outputs +! (mlam / eig_num / mvec) and a `method` selector. The body still +! drives the same chain of LAPACK helpers (DPBSTF, DSBGST, DSBTRD, +! DSTERF, DSTEQR, DSTEIN, DCOPY, DGEMV, DSWAP, DLACPY) plus the +! MYSTRAN-specific DSTEBZ_MYSTRAN below. + + SUBROUTINE DSBGVX_GIV_MGIV ( JOBZ, RANGE, UPLO, N, KA, KB, AB, & + & LDAB, BB, LDBB, Q, LDQ, VL, VU, & + & IL, IU, ABSTOL, mlam, W, Z, LDZ, & + & WORK, IWORK, IFAIL, INFO, & + & method, eig_num, mvec ) + +! .. Scalar Arguments .. + CHARACTER JOBZ, RANGE, UPLO + character(LEN=8) method + INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, & + & mlam, n, eig_num(n), mvec + REAL(DOUBLE) ABSTOL, VL, VU +! .. +! .. Array Arguments .. + INTEGER IFAIL( * ), IWORK( * ) + REAL(DOUBLE) AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), & + & W( * ), WORK( * ), Z( LDZ, * ) +! .. +! .. Parameters .. + REAL(DOUBLE) ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +! .. +! .. Local Scalars .. + LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ + CHARACTER ORDER, VECT + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP, & + & INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT + integer lowest_mode_num, highest_mode_num + REAL(DOUBLE) TMP1 +! .. +! .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +! .. +! .. External Subroutines .. + EXTERNAL XERBLA, DPBSTF, DSBGST, DSBTRD, DSTERF, DSTEQR,& + & DLACPY, DCOPY, DSTEIN, DGEMV, DSWAP +! .. +! .. Intrinsic Functions .. + INTRINSIC MIN +! .. +! .. Executable Statements .. + +! Initialize eig_num + do i=1,n + eig_num(i) = 0 + enddo + +! Test the input parameters. + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) + + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KA.LT.0 ) THEN + INFO = -5 + ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KA+1 ) THEN + INFO = -8 + ELSE IF( LDBB.LT.KB+1 ) THEN + INFO = -10 + ELSE IF( LDQ.LT.1 ) THEN + INFO = -12 + ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN + INFO = -14 + ELSE IF( INDEIG .AND. IL.LT.0 ) THEN + INFO = -15 + ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) ) ) THEN + INFO = -16 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -21 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSBGVX_GIV_MGIV', -INFO ) + END IF + +! Form a split Cholesky factorization of B. + if (method(1:3) == 'GIV') then + if (sol_name(1:8) == 'BUCKLING') then + CALL LINK_MESSAGE( & + & ' CHOLESKY FACTORIZATION OF DIFFER STIFF MATRIX') + else + CALL LINK_MESSAGE( & + & ' CHOLESKY FACTORIZATION OF MASS MATRIX') + endif + else if (method(1:4) == 'MGIV') then + CALL LINK_MESSAGE(' CHOLESKY FACTORIZATION OF STIFF MATRIX') + endif + CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF + +! Transform problem to standard eigenvalue problem. + CALL LINK_MESSAGE(' TRANSFORM TO STANDARD EIGENVALUE PROBLEM') + CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, & + & WORK, IINFO ) + +! Reduce symmetric band matrix to tridiagonal form. + CALL LINK_MESSAGE(' REDUCE SYMM BAND MATRIX TO TRIDIAG FORM') + INDD = 1 + INDE = INDD + N + INDWRK = INDE + N + IF( WANTZ ) THEN + VECT = 'U' + ELSE + VECT = 'N' + END IF + CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ), & + & WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO ) + +! If all eigenvalues are desired and ABSTOL <= 0, try DSTERF/DSTEQR +! first; fall back to DSTEBZ_MYSTRAN+DSTEIN if that fails. + IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.ge.N ) ) .AND. & + & ( ABSTOL.LE.ZERO ) ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, & + & WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 10 I = 1, N + IFAIL( I ) = 0 + 10 CONTINUE + END IF + END IF + + IF( INFO.EQ.0 ) THEN + mlam = N + mvec = N + GO TO 30 + END IF + INFO = 0 + END IF + +! Otherwise, call DSTEBZ_MYSTRAN and, if eigenvectors are desired, +! call DSTEIN. + if (info > 0) then + Write(err,9901) info + Write(f06,9901) info + endif + 9901 format(' *INFORMATION: LAPACK SUBR DSTERF OR DSTEQR HAS FAILED TO & + &FIND ALL OF THE EIGENVALUES IN A TOTAL OF 30*NDOFA ITERATIONS' & + &,/,14X,' A TOTAL OF ',I8,' SUB-DIAGONAL ELEMENTS OF THE TRIDIAGONA& + &L MATRIX E HAVE NOT CONVERGED TO ZERO.' & + &,/,14X,' LAPACK WILL ATTEMPT TO USE SUBR DSTEBZ TO FIND THE EIGENV& + &ALUES.',/) + + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ_MYSTRAN( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, & + & WORK( INDD ), WORK( INDE ), mlam, NSPLIT, W, & + & IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), & + & IWORK( INDIWO ), INFO, & + & lowest_mode_num, highest_mode_num ) + + if (info > 0) then + call eigenvalue_convergence_failure ( range, info ) + if ((info == 1) .or. (info == 3) .and. (range /= 'I')) then + Write(f06,9903) + do i=1,mlam + if (iwork(indibl-1+i) < 0) then + Write(f06,9904) i,w(i) + endif + enddo + Write(f06,*) + endif + endif + 9903 format(15x,'THE EIGENVALUES OF QUESTIONABLE VALUE ARE',/, & + & 15X,' INDEX EIGENVALUE') + 9904 FORMAT(15X,I8,1ES15.6) + + do i=1,mlam + if (method(1:3) == 'GIV') then + eig_num(i) = lowest_mode_num + (i - 1) + else + eig_num(i) = (n + 1) - (lowest_mode_num + (i - 1)) + endif + enddo + + IF( WANTZ ) THEN + mvec = mlam + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), mvec, W, & + & IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, & + & WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) + +! Apply transformation matrix used in reduction to tridiagonal +! form to eigenvectors returned by DSTEIN. + DO 20 J = 1, mvec + CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 ) + CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, & + & Z( 1, J ), 1 ) + 20 CONTINUE + END IF + + 30 CONTINUE + +! If eigenvalues are not in order, then sort them, along with +! eigenvectors. + IF( WANTZ ) THEN + DO 50 J = 1, mvec - 1 + I = 0 + TMP1 = W( J ) + DO 40 JJ = J + 1, mvec + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 40 CONTINUE + + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 50 CONTINUE + END IF + + RETURN + + END SUBROUTINE DSBGVX_GIV_MGIV + +! ################################################################################################################################## +! EIGENVALUE_CONVERGENCE_FAILURE + + SUBROUTINE EIGENVALUE_CONVERGENCE_FAILURE ( RANGE, INFO ) + + USE PARAMS, ONLY : SUPINFO + + character range + integer info + + Write(err,9902) + if (supinfo == 'N') then + Write(f06,9902) + endif + + if ((info == 1) .or. (info == 3) .and. (range /= 'I')) then + Write(err,99021) + Write(f06,99021) + else if ((info == 2) .or. (info == 3) .and. (range == 'I')) then + Write(err,99022) + Write(f06,99022) + else if (( info == 4) .and. (range == 'I')) then + Write(err,803) + Write(f06,803) + fatal_err = fatal_err + 1 + call outa_here ( 'Y' ) + endif + + 9902 format(' *INFORMATION: SOME OR ALL OF THE EIGENVALUES FAILED TO CO& + &NVERGE OR WERE NOT COMPUTED IN LAPACK SUBROUTINE DSTEBZ:') + +99021 format(15x,'BISECTION FAILED TO CONVERGE FOR SOME EIGENVALUES; THE& + &SE EIGENVALUES ARE FLAGGED BY A NEGATIVE BLOCK NUMBER.',/,15X, & + &'THE EFFECT IS THAT THE EIGENVALUES MAY NOT BE AS ACCURATE AS THE & + &ABSOLUTE AND RELATIVE TOLERANCES.',/,15X, & + &'THIS IS GENERALLY CAUSED BY UNEXPECTEDLY INACCURATE ARITHMETIC.' & + &,/) + +99022 format(15x,'NOT ALL OF THE EIGENVALUES IN THE RANGE REQUESTED WERE& + & FOUND:',/,15X, & + &'CAUSE: NON-MONOTONIC ARITHMETIC, CAUSING THE STURM SEQUENCE TO BE& + & NON-MONOTONIC.',/,15X, & + &'CURE : RECALCULATE, REQUESTING ALL EIGENVALUES',/) + + 803 format(' *ERROR 803: PROGRAMMING ERROR IN SUBROUTINE DSTEBZ.' & + &,/,15X,'NO EIGENVALUES WERE COMPUTED BY LAPACK SUBROUTINE DSTEBZ. & + &THE GERSHGORIN INTERVAL INITIALLY USED WAS TOO SMALL.',/,15X, & + &'PROBABLE CAUSE: YOUR MACHINE HAS SLOPPY FLOATING-POINT ARITHMETIC& + &',/,15X,'CURE : INCREASE THE PARAMETER "FUDGE" IN LAPACK & + &SUBROUTINE DSTEBZ, RECOMPILE, AND TRY AGAIN',/) + + END SUBROUTINE EIGENVALUE_CONVERGENCE_FAILURE + +! ################################################################################################################################## +! DSTEBZ_MYSTRAN +! +! Renamed copy of LAPACK DSTEBZ. The only deviation from upstream is +! that two extra outputs (lowest_mode_num, highest_mode_num) are +! returned at the end of the argument list. The numerical algorithm is +! unchanged. + + SUBROUTINE DSTEBZ_MYSTRAN( RANGE, ORDER, N, VL, VU, IL, IU, & + & ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, & + & WORK, IWORK, INFO, & + & lowest_mode_num, highest_mode_num ) + +! .. Scalar Arguments .. + CHARACTER ORDER, RANGE + INTEGER IL, INFO, IU, M, N, NSPLIT + integer lowest_mode_num, highest_mode_num + REAL(DOUBLE) ABSTOL, VL, VU +! .. +! .. Array Arguments .. + INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) + REAL(DOUBLE) D( * ), E( * ), W( * ), WORK( * ) +! .. +! .. Parameters .. + REAL(DOUBLE) ZERO, ONE, TWO, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, & + & HALF = 1.0D0 / TWO ) + REAL(DOUBLE) FUDGE, RELFAC + PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 ) +! .. +! .. Local Scalars .. + LOGICAL NCNVRG, TOOFEW + INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, & + & IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, & + & ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, & + & NWU + REAL(DOUBLE) ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, & + & TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL +! .. +! .. Local Arrays .. + INTEGER IDUMMA( 1 ) +! .. +! .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME + + REAL(DOUBLE) DLAMCH + EXTERNAL DLAMCH + + INTEGER ILAENV + EXTERNAL ILAENV +! .. +! .. External Subroutines .. + EXTERNAL DLAEBZ, XERBLA +! .. +! .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT +! .. +! .. Executable Statements .. + + INFO = 0 + +! Decode RANGE + IF( LSAME( RANGE, 'A' ) ) THEN + IRANGE = 1 + ELSE IF( LSAME( RANGE, 'V' ) ) THEN + IRANGE = 2 + ELSE IF( LSAME( RANGE, 'I' ) ) THEN + IRANGE = 3 + ELSE + IRANGE = 0 + END IF + +! Decode ORDER + IF( LSAME( ORDER, 'B' ) ) THEN + IORDER = 2 + ELSE IF( LSAME( ORDER, 'E' ) ) THEN + IORDER = 1 + ELSE + IORDER = 0 + END IF + +! Check for Errors + IF( IRANGE.LE.0 ) THEN + INFO = -1 + ELSE IF( IORDER.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( IRANGE.EQ.2 ) THEN + IF( VL.GE.VU ) & + & INFO = -5 + ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) & + & THEN + INFO = -6 + ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) & + & THEN + INFO = -7 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEBZ', -INFO ) + RETURN + END IF + + INFO = 0 + NCNVRG = .FALSE. + TOOFEW = .FALSE. + + M = 0 + IF( N.EQ.0 ) RETURN + + IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) & + & IRANGE = 1 + + SAFEMN = DLAMCH( 'S' ) + ULP = DLAMCH( 'P' ) + RTOLI = ULP*RELFAC + NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) + IF( NB.LE.1 ) NB = 0 + +! Special Case when N=1 + IF( N.EQ.1 ) THEN + NSPLIT = 1 + ISPLIT( 1 ) = 1 + IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN + M = 0 + ELSE + W( 1 ) = D( 1 ) + IBLOCK( 1 ) = 1 + M = 1 + END IF + highest_mode_num = 1 + lowest_mode_num = 1 + RETURN + END IF + +! Compute Splitting Points + NSPLIT = 1 + WORK( N ) = ZERO + PIVMIN = ONE + +!DIR$ NOVECTOR + DO 10 J = 2, N + TMP1 = E( J-1 )**2 + IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN + ISPLIT( NSPLIT ) = J - 1 + NSPLIT = NSPLIT + 1 + WORK( J-1 ) = ZERO + ELSE + WORK( J-1 ) = TMP1 + PIVMIN = MAX( PIVMIN, TMP1 ) + END IF + 10 CONTINUE + ISPLIT( NSPLIT ) = N + PIVMIN = PIVMIN*SAFEMN + + IF( IRANGE.EQ.3 ) THEN + GU = D( 1 ) + GL = D( 1 ) + TMP1 = ZERO + + DO 20 J = 1, N - 1 + TMP2 = SQRT( WORK( J ) ) + GU = MAX( GU, D( J )+TMP1+TMP2 ) + GL = MIN( GL, D( J )-TMP1-TMP2 ) + TMP1 = TMP2 + 20 CONTINUE + + GU = MAX( GU, D( N )+TMP1 ) + GL = MIN( GL, D( N )-TMP1 ) + TNORM = MAX( ABS( GL ), ABS( GU ) ) + GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN + GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN + + ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / & + & LOG( TWO ) ) + 2 + IF( ABSTOL.LE.ZERO ) THEN + ATOLI = ULP*TNORM + ELSE + ATOLI = ABSTOL + END IF + + WORK( N+1 ) = GL + WORK( N+2 ) = GL + WORK( N+3 ) = GU + WORK( N+4 ) = GU + WORK( N+5 ) = GL + WORK( N+6 ) = GU + IWORK( 1 ) = -1 + IWORK( 2 ) = -1 + IWORK( 3 ) = N + 1 + IWORK( 4 ) = N + 1 + IWORK( 5 ) = IL - 1 + IWORK( 6 ) = IU + + CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,& + & WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, & + & IWORK, W, IBLOCK, IINFO ) + + IF( IWORK( 6 ).EQ.IU ) THEN + WL = WORK( N+1 ) + WLU = WORK( N+3 ) + NWL = IWORK( 1 ) + WU = WORK( N+4 ) + WUL = WORK( N+2 ) + NWU = IWORK( 4 ) + ELSE + WL = WORK( N+2 ) + WLU = WORK( N+4 ) + NWL = IWORK( 2 ) + WU = WORK( N+3 ) + WUL = WORK( N+1 ) + NWU = IWORK( 3 ) + END IF + + IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN + INFO = 4 + RETURN + END IF + ELSE + TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), & + & ABS( D( N ) )+ABS( E( N-1 ) ) ) + + DO 30 J = 2, N - 1 + TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ & + & ABS( E( J ) ) ) + 30 CONTINUE + + IF( ABSTOL.LE.ZERO ) THEN + ATOLI = ULP*TNORM + ELSE + ATOLI = ABSTOL + END IF + + IF( IRANGE.EQ.2 ) THEN + WL = VL + WU = VU + ELSE + WL = ZERO + WU = ZERO + END IF + END IF + + M = 0 + IEND = 0 + INFO = 0 + NWL = 0 + NWU = 0 + + DO 70 JB = 1, NSPLIT + IOFF = IEND + IBEGIN = IOFF + 1 + IEND = ISPLIT( JB ) + IN = IEND - IOFF + + IF( IN.EQ.1 ) THEN + IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) & + & NWL = NWL + 1 + IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) & + & NWU = NWU + 1 + IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.& + & D( IBEGIN )-PIVMIN ) ) THEN + M = M + 1 + W( M ) = D( IBEGIN ) + IBLOCK( M ) = JB + END IF + ELSE + GU = D( IBEGIN ) + GL = D( IBEGIN ) + TMP1 = ZERO + + DO 40 J = IBEGIN, IEND - 1 + TMP2 = ABS( E( J ) ) + GU = MAX( GU, D( J )+TMP1+TMP2 ) + GL = MIN( GL, D( J )-TMP1-TMP2 ) + TMP1 = TMP2 + 40 CONTINUE + + GU = MAX( GU, D( IEND )+TMP1 ) + GL = MIN( GL, D( IEND )-TMP1 ) + BNORM = MAX( ABS( GL ), ABS( GU ) ) + GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN + GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN + + IF( ABSTOL.LE.ZERO ) THEN + ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) ) + ELSE + ATOLI = ABSTOL + END IF + + IF( IRANGE.GT.1 ) THEN + IF( GU.LT.WL ) THEN + NWL = NWL + IN + NWU = NWU + IN + GO TO 70 + END IF + GL = MAX( GL, WL ) + GU = MIN( GU, WU ) + IF( GL.GE.GU ) & + & GO TO 70 + END IF + + WORK( N+1 ) = GL + WORK( N+IN+1 ) = GU + CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, & + & D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), & + & IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, & + & IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) + + NWL = NWL + IWORK( 1 ) + NWU = NWU + IWORK( IN+1 ) + IWOFF = M - IWORK( 1 ) + + ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / & + & LOG( TWO ) ) + 2 + CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, & + & D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), & + & IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, & + & IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) + + DO 60 J = 1, IOUT + TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) + + IF( J.GT.IOUT-IINFO ) THEN + NCNVRG = .TRUE. + IB = -JB + ELSE + IB = JB + END IF + DO 50 JE = IWORK( J ) + 1 + IWOFF, & + & IWORK( J+IN ) + IWOFF + W( JE ) = TMP1 + IBLOCK( JE ) = IB + 50 CONTINUE + 60 CONTINUE + + M = M + IM + END IF + 70 CONTINUE + + IF( IRANGE.EQ.3 ) THEN + IM = 0 + IDISCL = IL - 1 - NWL + IDISCU = NWU - IU + + IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN + DO 80 JE = 1, M + IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN + IDISCL = IDISCL - 1 + ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN + IDISCU = IDISCU - 1 + ELSE + IM = IM + 1 + W( IM ) = W( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 80 CONTINUE + M = IM + END IF + IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN + IF( IDISCL.GT.0 ) THEN + WKILL = WU + DO 100 JDISC = 1, IDISCL + IW = 0 + DO 90 JE = 1, M + IF( IBLOCK( JE ).NE.0 .AND. & + & ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN + IW = JE + WKILL = W( JE ) + END IF + 90 CONTINUE + IBLOCK( IW ) = 0 + 100 CONTINUE + END IF + IF( IDISCU.GT.0 ) THEN + WKILL = WL + DO 120 JDISC = 1, IDISCU + IW = 0 + DO 110 JE = 1, M + IF( IBLOCK( JE ).NE.0 .AND. & + & ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN + IW = JE + WKILL = W( JE ) + END IF + 110 CONTINUE + IBLOCK( IW ) = 0 + 120 CONTINUE + END IF + IM = 0 + DO 130 JE = 1, M + IF( IBLOCK( JE ).NE.0 ) THEN + IM = IM + 1 + W( IM ) = W( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 130 CONTINUE + M = IM + END IF + IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN + TOOFEW = .TRUE. + END IF + END IF + + IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN + DO 150 JE = 1, M - 1 + IE = 0 + TMP1 = W( JE ) + DO 140 J = JE + 1, M + IF( W( J ).LT.TMP1 ) THEN + IE = J + TMP1 = W( J ) + END IF + 140 CONTINUE + + IF( IE.NE.0 ) THEN + ITMP1 = IBLOCK( IE ) + W( IE ) = W( JE ) + IBLOCK( IE ) = IBLOCK( JE ) + W( JE ) = TMP1 + IBLOCK( JE ) = ITMP1 + END IF + 150 CONTINUE + END IF + + highest_mode_num = nwu + lowest_mode_num = highest_mode_num - m + 1 + + INFO = 0 + IF( NCNVRG ) INFO = INFO + 1 + IF( TOOFEW ) INFO = INFO + 2 + + RETURN + + END SUBROUTINE DSTEBZ_MYSTRAN + + END MODULE MYSTRAN_LAPACK_EXT diff --git a/Source/UTIL/COND_NUM.f90 b/Source/UTIL/COND_NUM.f90 index 7702d745..d48414f5 100644 --- a/Source/UTIL/COND_NUM.f90 +++ b/Source/UTIL/COND_NUM.f90 @@ -30,12 +30,11 @@ SUBROUTINE COND_NUM ( MATIN_NAME, N, KD, K_INORM, MATIN_FAC, RCOND ) ! Uses the triangular factor of the matrix, which is called MATIN_FAC. USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : WRT_ERR + USE IOUNT1, ONLY : WRT_ERR, ERR, F06 USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR USE CONSTANTS_1, ONLY : ZERO USE PARAMS, ONLY : ITMAX USE TIMDAT, ONLY : TSEC - USE LAPACK_LIN_EQN_DPB ! Interface module not needed for subr DPBCON. This is "CONTAIN'ed" in module LAPACK_LIN_EQN_DPB, which is "USE'd" above @@ -73,7 +72,7 @@ SUBROUTINE COND_NUM ( MATIN_NAME, N, KD, K_INORM, MATIN_FAC, RCOND ) ! in a call to a LAPACK subr. !xx WRITE(SC1, * ) - CALL DPBCON( UPLO, N, KD, MATIN_FAC, KD+1, K_INORM, RCOND, WORK, IWORK, INFO, ITMAX, 'Y' ) + CALL DPBCON( UPLO, N, KD, MATIN_FAC, KD+1, K_INORM, RCOND, WORK, IWORK, INFO ) CALLED_SUBR = 'DPBCON ' IF (INFO < 0) THEN ! LAPACK subr XERBLA should have reported error on an illegal argument diff --git a/Source/UTIL/FBS_LAPACK.f90 b/Source/UTIL/FBS_LAPACK.f90 index 1ae1f3ef..cb493368 100644 --- a/Source/UTIL/FBS_LAPACK.f90 +++ b/Source/UTIL/FBS_LAPACK.f90 @@ -43,7 +43,6 @@ SUBROUTINE FBS_LAPACK ( EQUED, NROWS, MATIN_SDIA, EQUIL_SCALE_FACS, INOUT_COL ) USE LAPACK_DPB_MATRICES, ONLY : ABAND, LAPACK_S, RES USE DEBUG_PARAMETERS, ONLY : DEBUG, NDEBUG USE MACHINE_PARAMS, ONLY : MACH_EPS, MACH_SFMIN - USE LAPACK_LIN_EQN_DPB USE SYM_MAT_DECOMP_LAPACK_USE_IFs @@ -88,7 +87,7 @@ SUBROUTINE FBS_LAPACK ( EQUED, NROWS, MATIN_SDIA, EQUIL_SCALE_FACS, INOUT_COL ) ! Calculate the answer via forward/backward substitution. Subr DPBTRS returns the answer in the workspace (INOUT_COL) ! for the right-hand side (which, at entry, was INOUT_COL) - CALL DPBTRS ( UPLO, NROWS, MATIN_SDIA, NUM_COLS, ABAND, MATIN_SDIA+1, INOUT_COL, NROWS, INFO, 'N' ) + CALL DPBTRS ( UPLO, NROWS, MATIN_SDIA, NUM_COLS, ABAND, MATIN_SDIA+1, INOUT_COL, NROWS, INFO ) CALLED_SUBR = 'DPBTRS' IF (INFO < 0) THEN ! LAPACK subr XERBLA should have reported error on an illegal argument diff --git a/Source/UTIL/GET_MACHINE_PARAMS.f90 b/Source/UTIL/GET_MACHINE_PARAMS.f90 index 44864364..7b27ee2c 100644 --- a/Source/UTIL/GET_MACHINE_PARAMS.f90 +++ b/Source/UTIL/GET_MACHINE_PARAMS.f90 @@ -29,14 +29,13 @@ SUBROUTINE GET_MACHINE_PARAMS ! Use LAPACK function DLAMCH to get machine parameters for the users' computer USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : WRT_ERR + USE IOUNT1, ONLY : WRT_ERR, F06 USE SCONTR, ONLY : BLNK_SUB_NAM USE TIMDAT, ONLY : TSEC USE CONSTANTS_1, ONLY : ONE USE MACHINE_PARAMS, ONLY : MACH_BASE, MACH_EMAX, MACH_EMIN, MACH_EPS, MACH_PREC, MACH_RMAX, MACH_RMIN, MACH_RND, & MACH_SFMIN, MACH_T, MACH_LARGE_NUM USE DEBUG_PARAMETERS, ONLY : DEBUG - USE LAPACK_BLAS_AUX USE GET_MACHINE_PARAMS_USE_IFs diff --git a/Source/UTIL/INVERT_FF_MAT.f90 b/Source/UTIL/INVERT_FF_MAT.f90 index 5051cab3..d0cad53a 100644 --- a/Source/UTIL/INVERT_FF_MAT.f90 +++ b/Source/UTIL/INVERT_FF_MAT.f90 @@ -32,7 +32,6 @@ SUBROUTINE INVERT_FF_MAT ( CALLING_SUBR, MAT_A_NAME, A, NROWS, INFO ) USE IOUNT1, ONLY : WRT_ERR, ERR, F06 USE SCONTR, ONLY : BLNK_SUB_NAM, FATAL_ERR USE TIMDAT, ONLY : TSEC - USE LAPACK_SYM_MAT_INV USE INVERT_FF_MAT_USE_IFs diff --git a/Source/UTIL/SYM_MAT_DECOMP_LAPACK.f90 b/Source/UTIL/SYM_MAT_DECOMP_LAPACK.f90 index e5b752ee..6b950dfe 100644 --- a/Source/UTIL/SYM_MAT_DECOMP_LAPACK.f90 +++ b/Source/UTIL/SYM_MAT_DECOMP_LAPACK.f90 @@ -33,14 +33,13 @@ SUBROUTINE SYM_MAT_DECOMP_LAPACK ( CALLING_SUBR, MATIN_NAME, MATIN_SET, NROWS, N ! actual work USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - USE IOUNT1, ONLY : ERR, F06 + USE IOUNT1, ONLY : ERR, F06, SC1 USE SCONTR, ONLY : BLNK_SUB_NAM, FACTORED_MATRIX, FATAL_ERR, LINKNO USE TIMDAT, ONLY : TSEC USE CONSTANTS_1, ONLY : ZERO, ONE, ONEPP6 USE PARAMS, ONLY : BAILOUT, EPSIL, SUPINFO USE LAPACK_DPB_MATRICES, ONLY : ABAND, LAPACK_S USE DEBUG_PARAMETERS, ONLY : DEBUG, NDEBUG - USE LAPACK_LIN_EQN_DPB USE SYM_MAT_DECOMP_LAPACK_USE_IFs USE LINK_MESSAGE_Interface @@ -106,6 +105,8 @@ SUBROUTINE SYM_MAT_DECOMP_LAPACK ( CALLING_SUBR, MATIN_NAME, MATIN_SET, NROWS, N LOGICAL :: FACTORIZATION_PROBLEM + REAL(DOUBLE), EXTERNAL :: DLANSB + INTRINSIC :: DABS diff --git a/Source/lapack b/Source/lapack new file mode 160000 index 00000000..20044bbd --- /dev/null +++ b/Source/lapack @@ -0,0 +1 @@ +Subproject commit 20044bbd951fe895b2030c35fe9e4fc658f22576 diff --git a/build/CPackConfig.cmake b/build/CPackConfig.cmake new file mode 100644 index 00000000..c3d252c3 --- /dev/null +++ b/build/CPackConfig.cmake @@ -0,0 +1,70 @@ +# This file will be configured to contain variables for CPack. These variables +# should be set in the CMake list file of the project before CPack module is +# included. The list of available CPACK_xxx variables and their associated +# documentation may be obtained using +# cpack --help-variable-list +# +# Some variables are common to all generators (e.g. CPACK_PACKAGE_NAME) +# and some are specific to a generator +# (e.g. CPACK_NSIS_EXTRA_INSTALL_COMMANDS). The generator specific variables +# usually begin with CPACK__xxxx. + + +set(CPACK_ARCHIVE_GID "-1") +set(CPACK_ARCHIVE_UID "-1") +set(CPACK_BUILD_SOURCE_DIRS "/home/bruno/Git/MYSTRAN;/home/bruno/Git/MYSTRAN/build") +set(CPACK_CMAKE_GENERATOR "Ninja") +set(CPACK_COMPONENT_UNSPECIFIED_HIDDEN "TRUE") +set(CPACK_COMPONENT_UNSPECIFIED_REQUIRED "TRUE") +set(CPACK_DEFAULT_PACKAGE_DESCRIPTION_FILE "/usr/share/cmake/Templates/CPack.GenericDescription.txt") +set(CPACK_DEFAULT_PACKAGE_DESCRIPTION_SUMMARY "Mystran built using CMake") +set(CPACK_DMG_SLA_USE_RESOURCE_FILE_LICENSE "ON") +set(CPACK_GENERATOR "TGZ") +set(CPACK_INNOSETUP_ARCHITECTURE "x64") +set(CPACK_INSTALL_CMAKE_PROJECTS "/home/bruno/Git/MYSTRAN/build;Mystran;ALL;/") +set(CPACK_INSTALL_PREFIX "/usr/local") +set(CPACK_MODULE_PATH "/home/bruno/Git/MYSTRAN/Source/lapack/CMAKE") +set(CPACK_MONOLITHIC_INSTALL "ON") +set(CPACK_NSIS_DISPLAY_NAME "LAPACK") +set(CPACK_NSIS_INSTALLER_ICON_CODE "") +set(CPACK_NSIS_INSTALLER_MUI_ICON_CODE "") +set(CPACK_NSIS_INSTALL_ROOT "$PROGRAMFILES") +set(CPACK_NSIS_PACKAGE_NAME "LAPACK") +set(CPACK_NSIS_UNINSTALL_NAME "Uninstall") +set(CPACK_OBJCOPY_EXECUTABLE "/usr/bin/objcopy") +set(CPACK_OBJDUMP_EXECUTABLE "/usr/bin/objdump") +set(CPACK_OUTPUT_CONFIG_FILE "/home/bruno/Git/MYSTRAN/build/CPackConfig.cmake") +set(CPACK_PACKAGE_DEFAULT_LOCATION "/") +set(CPACK_PACKAGE_DESCRIPTION_FILE "/usr/share/cmake/Templates/CPack.GenericDescription.txt") +set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "LAPACK- Linear Algebra Package") +set(CPACK_PACKAGE_FILE_NAME "LAPACK-3.12.1-Linux") +set(CPACK_PACKAGE_INSTALL_DIRECTORY "LAPACK") +set(CPACK_PACKAGE_INSTALL_REGISTRY_KEY "LAPACK") +set(CPACK_PACKAGE_NAME "LAPACK") +set(CPACK_PACKAGE_RELOCATABLE "true") +set(CPACK_PACKAGE_VENDOR "University of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd") +set(CPACK_PACKAGE_VERSION "3.12.1") +set(CPACK_PACKAGE_VERSION_MAJOR "3") +set(CPACK_PACKAGE_VERSION_MINOR "12") +set(CPACK_PACKAGE_VERSION_PATCH "1") +set(CPACK_READELF_EXECUTABLE "/usr/bin/readelf") +set(CPACK_RESOURCE_FILE_LICENSE "/home/bruno/Git/MYSTRAN/Source/lapack/LICENSE") +set(CPACK_RESOURCE_FILE_README "/usr/share/cmake/Templates/CPack.GenericDescription.txt") +set(CPACK_RESOURCE_FILE_WELCOME "/usr/share/cmake/Templates/CPack.GenericWelcome.txt") +set(CPACK_SET_DESTDIR "OFF") +set(CPACK_SOURCE_GENERATOR "TGZ") +set(CPACK_SOURCE_IGNORE_FILES "~$;.svn") +set(CPACK_SOURCE_OUTPUT_CONFIG_FILE "/home/bruno/Git/MYSTRAN/build/CPackSourceConfig.cmake") +set(CPACK_SOURCE_PACKAGE_FILE_NAME "lapack-3.12.1") +set(CPACK_SYSTEM_NAME "Linux") +set(CPACK_THREADS "1") +set(CPACK_TOPLEVEL_TAG "Linux") +set(CPACK_WIX_SIZEOF_VOID_P "8") + +if(NOT CPACK_PROPERTIES_FILE) + set(CPACK_PROPERTIES_FILE "/home/bruno/Git/MYSTRAN/build/CPackProperties.cmake") +endif() + +if(EXISTS ${CPACK_PROPERTIES_FILE}) + include(${CPACK_PROPERTIES_FILE}) +endif() diff --git a/build/CPackSourceConfig.cmake b/build/CPackSourceConfig.cmake new file mode 100644 index 00000000..a68d6dc5 --- /dev/null +++ b/build/CPackSourceConfig.cmake @@ -0,0 +1,76 @@ +# This file will be configured to contain variables for CPack. These variables +# should be set in the CMake list file of the project before CPack module is +# included. The list of available CPACK_xxx variables and their associated +# documentation may be obtained using +# cpack --help-variable-list +# +# Some variables are common to all generators (e.g. CPACK_PACKAGE_NAME) +# and some are specific to a generator +# (e.g. CPACK_NSIS_EXTRA_INSTALL_COMMANDS). The generator specific variables +# usually begin with CPACK__xxxx. + + +set(CPACK_ARCHIVE_GID "-1") +set(CPACK_ARCHIVE_UID "-1") +set(CPACK_BUILD_SOURCE_DIRS "/home/bruno/Git/MYSTRAN;/home/bruno/Git/MYSTRAN/build") +set(CPACK_CMAKE_GENERATOR "Ninja") +set(CPACK_COMPONENT_UNSPECIFIED_HIDDEN "TRUE") +set(CPACK_COMPONENT_UNSPECIFIED_REQUIRED "TRUE") +set(CPACK_DEFAULT_PACKAGE_DESCRIPTION_FILE "/usr/share/cmake/Templates/CPack.GenericDescription.txt") +set(CPACK_DEFAULT_PACKAGE_DESCRIPTION_SUMMARY "Mystran built using CMake") +set(CPACK_DMG_SLA_USE_RESOURCE_FILE_LICENSE "ON") +set(CPACK_GENERATOR "TGZ") +set(CPACK_IGNORE_FILES "~$;.svn") +set(CPACK_INNOSETUP_ARCHITECTURE "x64") +set(CPACK_INSTALLED_DIRECTORIES "/home/bruno/Git/MYSTRAN;/") +set(CPACK_INSTALL_CMAKE_PROJECTS "") +set(CPACK_INSTALL_PREFIX "/usr/local") +set(CPACK_MODULE_PATH "/home/bruno/Git/MYSTRAN/Source/lapack/CMAKE") +set(CPACK_MONOLITHIC_INSTALL "ON") +set(CPACK_NSIS_DISPLAY_NAME "LAPACK") +set(CPACK_NSIS_INSTALLER_ICON_CODE "") +set(CPACK_NSIS_INSTALLER_MUI_ICON_CODE "") +set(CPACK_NSIS_INSTALL_ROOT "$PROGRAMFILES") +set(CPACK_NSIS_PACKAGE_NAME "LAPACK") +set(CPACK_NSIS_UNINSTALL_NAME "Uninstall") +set(CPACK_OBJCOPY_EXECUTABLE "/usr/bin/objcopy") +set(CPACK_OBJDUMP_EXECUTABLE "/usr/bin/objdump") +set(CPACK_OUTPUT_CONFIG_FILE "/home/bruno/Git/MYSTRAN/build/CPackConfig.cmake") +set(CPACK_PACKAGE_DEFAULT_LOCATION "/") +set(CPACK_PACKAGE_DESCRIPTION_FILE "/usr/share/cmake/Templates/CPack.GenericDescription.txt") +set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "LAPACK- Linear Algebra Package") +set(CPACK_PACKAGE_FILE_NAME "lapack-3.12.1") +set(CPACK_PACKAGE_INSTALL_DIRECTORY "LAPACK") +set(CPACK_PACKAGE_INSTALL_REGISTRY_KEY "LAPACK") +set(CPACK_PACKAGE_NAME "LAPACK") +set(CPACK_PACKAGE_RELOCATABLE "true") +set(CPACK_PACKAGE_VENDOR "University of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd") +set(CPACK_PACKAGE_VERSION "3.12.1") +set(CPACK_PACKAGE_VERSION_MAJOR "3") +set(CPACK_PACKAGE_VERSION_MINOR "12") +set(CPACK_PACKAGE_VERSION_PATCH "1") +set(CPACK_READELF_EXECUTABLE "/usr/bin/readelf") +set(CPACK_RESOURCE_FILE_LICENSE "/home/bruno/Git/MYSTRAN/Source/lapack/LICENSE") +set(CPACK_RESOURCE_FILE_README "/usr/share/cmake/Templates/CPack.GenericDescription.txt") +set(CPACK_RESOURCE_FILE_WELCOME "/usr/share/cmake/Templates/CPack.GenericWelcome.txt") +set(CPACK_RPM_PACKAGE_SOURCES "ON") +set(CPACK_SET_DESTDIR "OFF") +set(CPACK_SOURCE_GENERATOR "TGZ") +set(CPACK_SOURCE_IGNORE_FILES "~$;.svn") +set(CPACK_SOURCE_INSTALLED_DIRECTORIES "/home/bruno/Git/MYSTRAN;/") +set(CPACK_SOURCE_OUTPUT_CONFIG_FILE "/home/bruno/Git/MYSTRAN/build/CPackSourceConfig.cmake") +set(CPACK_SOURCE_PACKAGE_FILE_NAME "lapack-3.12.1") +set(CPACK_SOURCE_TOPLEVEL_TAG "Linux-Source") +set(CPACK_STRIP_FILES "") +set(CPACK_SYSTEM_NAME "Linux") +set(CPACK_THREADS "1") +set(CPACK_TOPLEVEL_TAG "Linux-Source") +set(CPACK_WIX_SIZEOF_VOID_P "8") + +if(NOT CPACK_PROPERTIES_FILE) + set(CPACK_PROPERTIES_FILE "/home/bruno/Git/MYSTRAN/build/CPackProperties.cmake") +endif() + +if(EXISTS ${CPACK_PROPERTIES_FILE}) + include(${CPACK_PROPERTIES_FILE}) +endif() diff --git a/build/superlu/FORTRAN/superlu_config.h b/build/superlu/FORTRAN/superlu_config.h new file mode 100644 index 00000000..eeb2a1e4 --- /dev/null +++ b/build/superlu/FORTRAN/superlu_config.h @@ -0,0 +1,24 @@ + +#ifndef SUPERLU_CONFIG_H +#define SUPERLU_CONFIG_H + +/* Enable metis */ +#define HAVE_METIS TRUE + +/* Enable colamd */ +/* #undef HAVE_COLAMD */ + +/* enable 64bit index mode */ +/* #undef XSDK_INDEX_SIZE */ + +/* Integer type for indexing sparse matrix meta structure */ +#if defined(XSDK_INDEX_SIZE) && (XSDK_INDEX_SIZE == 64) +#include +#define _LONGINT 1 +typedef int64_t int_t; +#else +typedef int int_t; /* default */ +#endif + +#endif /* SUPERLU_CONFIG_H */ + diff --git a/build/superlu/SRC/superluConfig.cmake b/build/superlu/SRC/superluConfig.cmake new file mode 100644 index 00000000..440cc4a4 --- /dev/null +++ b/build/superlu/SRC/superluConfig.cmake @@ -0,0 +1,39 @@ + +####### Expanded from @PACKAGE_INIT@ by configure_package_config_file() ####### +####### Any changes to this file will be overwritten by the next CMake run #### +####### The input file was superluConfig.cmake.in ######## + +get_filename_component(PACKAGE_PREFIX_DIR "${CMAKE_CURRENT_LIST_DIR}/../../../../../../../../usr/local" ABSOLUTE) + +macro(set_and_check _var _file) + set(${_var} "${_file}") + if(NOT EXISTS "${_file}") + message(FATAL_ERROR "File or directory ${_file} referenced by variable ${_var} does not exist !") + endif() +endmacro() + +macro(check_required_components _NAME) + foreach(comp ${${_NAME}_FIND_COMPONENTS}) + if(NOT ${_NAME}_${comp}_FOUND) + if(${_NAME}_FIND_REQUIRED_${comp}) + set(${_NAME}_FOUND FALSE) + endif() + endif() + endforeach() +endmacro() + +#################################################################################### + +include(CMakeFindDependencyMacro) + +set(enable_blaslib ) + +list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}") + +if(NOT enable_blaslib) + find_dependency(BLAS) +else() + include("${CMAKE_CURRENT_LIST_DIR}/blasTargets.cmake") +endif() + +include("${CMAKE_CURRENT_LIST_DIR}/superluTargets.cmake") diff --git a/build/superlu/SRC/superluConfigVersion.cmake b/build/superlu/SRC/superluConfigVersion.cmake new file mode 100644 index 00000000..29367693 --- /dev/null +++ b/build/superlu/SRC/superluConfigVersion.cmake @@ -0,0 +1,65 @@ +# This is a basic version file for the Config-mode of find_package(). +# It is used by write_basic_package_version_file() as input file for configure_file() +# to create a version-file which can be installed along a config.cmake file. +# +# The created file sets PACKAGE_VERSION_EXACT if the current version string and +# the requested version string are exactly the same and it sets +# PACKAGE_VERSION_COMPATIBLE if the current version is >= requested version, +# but only if the requested major version is the same as the current one. +# The variable CVF_VERSION must be set before calling configure_file(). + + +set(PACKAGE_VERSION "7.0.1") + +if(PACKAGE_VERSION VERSION_LESS PACKAGE_FIND_VERSION) + set(PACKAGE_VERSION_COMPATIBLE FALSE) +else() + + if("7.0.1" MATCHES "^([0-9]+)\\.") + set(CVF_VERSION_MAJOR "${CMAKE_MATCH_1}") + if(NOT CVF_VERSION_MAJOR VERSION_EQUAL 0) + string(REGEX REPLACE "^0+" "" CVF_VERSION_MAJOR "${CVF_VERSION_MAJOR}") + endif() + else() + set(CVF_VERSION_MAJOR "7.0.1") + endif() + + if(PACKAGE_FIND_VERSION_RANGE) + # both endpoints of the range must have the expected major version + math (EXPR CVF_VERSION_MAJOR_NEXT "${CVF_VERSION_MAJOR} + 1") + if (NOT PACKAGE_FIND_VERSION_MIN_MAJOR STREQUAL CVF_VERSION_MAJOR + OR ((PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "INCLUDE" AND NOT PACKAGE_FIND_VERSION_MAX_MAJOR STREQUAL CVF_VERSION_MAJOR) + OR (PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "EXCLUDE" AND NOT PACKAGE_FIND_VERSION_MAX VERSION_LESS_EQUAL CVF_VERSION_MAJOR_NEXT))) + set(PACKAGE_VERSION_COMPATIBLE FALSE) + elseif(PACKAGE_FIND_VERSION_MIN_MAJOR STREQUAL CVF_VERSION_MAJOR + AND ((PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "INCLUDE" AND PACKAGE_VERSION VERSION_LESS_EQUAL PACKAGE_FIND_VERSION_MAX) + OR (PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "EXCLUDE" AND PACKAGE_VERSION VERSION_LESS PACKAGE_FIND_VERSION_MAX))) + set(PACKAGE_VERSION_COMPATIBLE TRUE) + else() + set(PACKAGE_VERSION_COMPATIBLE FALSE) + endif() + else() + if(PACKAGE_FIND_VERSION_MAJOR STREQUAL CVF_VERSION_MAJOR) + set(PACKAGE_VERSION_COMPATIBLE TRUE) + else() + set(PACKAGE_VERSION_COMPATIBLE FALSE) + endif() + + if(PACKAGE_FIND_VERSION STREQUAL PACKAGE_VERSION) + set(PACKAGE_VERSION_EXACT TRUE) + endif() + endif() +endif() + + +# if the installed or the using project don't have CMAKE_SIZEOF_VOID_P set, ignore it: +if("${CMAKE_SIZEOF_VOID_P}" STREQUAL "" OR "8" STREQUAL "") + return() +endif() + +# check that the installed version has the same 32/64bit-ness as the one which is currently searching: +if(NOT CMAKE_SIZEOF_VOID_P STREQUAL "8") + math(EXPR installedBits "8 * 8") + set(PACKAGE_VERSION "${PACKAGE_VERSION} (${installedBits}bit)") + set(PACKAGE_VERSION_UNSUITABLE TRUE) +endif() diff --git a/build/superlu/SRC/superluTargets.cmake b/build/superlu/SRC/superluTargets.cmake new file mode 100644 index 00000000..ad47c3a3 --- /dev/null +++ b/build/superlu/SRC/superluTargets.cmake @@ -0,0 +1,85 @@ +# Generated by CMake + +if("${CMAKE_MAJOR_VERSION}.${CMAKE_MINOR_VERSION}" LESS 2.8) + message(FATAL_ERROR "CMake >= 2.8.3 required") +endif() +if(CMAKE_VERSION VERSION_LESS "2.8.3") + message(FATAL_ERROR "CMake >= 2.8.3 required") +endif() +cmake_policy(PUSH) +cmake_policy(VERSION 2.8.3...4.1) +#---------------------------------------------------------------- +# Generated CMake target import file. +#---------------------------------------------------------------- + +# Commands may need to know the format version. +set(CMAKE_IMPORT_FILE_VERSION 1) + +# Protect against multiple inclusion, which would fail when already imported targets are added once more. +set(_cmake_targets_defined "") +set(_cmake_targets_not_defined "") +set(_cmake_expected_targets "") +foreach(_cmake_expected_target IN ITEMS superlu::superlu) + list(APPEND _cmake_expected_targets "${_cmake_expected_target}") + if(TARGET "${_cmake_expected_target}") + list(APPEND _cmake_targets_defined "${_cmake_expected_target}") + else() + list(APPEND _cmake_targets_not_defined "${_cmake_expected_target}") + endif() +endforeach() +unset(_cmake_expected_target) +if(_cmake_targets_defined STREQUAL _cmake_expected_targets) + unset(_cmake_targets_defined) + unset(_cmake_targets_not_defined) + unset(_cmake_expected_targets) + unset(CMAKE_IMPORT_FILE_VERSION) + cmake_policy(POP) + return() +endif() +if(NOT _cmake_targets_defined STREQUAL "") + string(REPLACE ";" ", " _cmake_targets_defined_text "${_cmake_targets_defined}") + string(REPLACE ";" ", " _cmake_targets_not_defined_text "${_cmake_targets_not_defined}") + message(FATAL_ERROR "Some (but not all) targets in this export set were already defined.\nTargets Defined: ${_cmake_targets_defined_text}\nTargets not yet defined: ${_cmake_targets_not_defined_text}\n") +endif() +unset(_cmake_targets_defined) +unset(_cmake_targets_not_defined) +unset(_cmake_expected_targets) + + +# Create imported target superlu::superlu +add_library(superlu::superlu STATIC IMPORTED) + +set_target_properties(superlu::superlu PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES "/home/bruno/Git/MYSTRAN/superlu/SRC" + INTERFACE_LINK_LIBRARIES "blas;/home/bruno/Git/MYSTRAN/Binaries/lib/libmetis.a;/home/bruno/Git/MYSTRAN/Binaries/lib/libGKlib.a;m" +) + +# Import target "superlu::superlu" for configuration "Debug" +set_property(TARGET superlu::superlu APPEND PROPERTY IMPORTED_CONFIGURATIONS DEBUG) +set_target_properties(superlu::superlu PROPERTIES + IMPORTED_LINK_INTERFACE_LANGUAGES_DEBUG "C" + IMPORTED_LOCATION_DEBUG "/home/bruno/Git/MYSTRAN/Binaries/lib/libsuperlu.a" + ) + +# Make sure the targets which have been exported in some other +# export set exist. +unset(${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets) +foreach(_target "blas" ) + if(NOT TARGET "${_target}" ) + set(${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets "${${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets} ${_target}") + endif() +endforeach() + +if(DEFINED ${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets) + if(CMAKE_FIND_PACKAGE_NAME) + set( ${CMAKE_FIND_PACKAGE_NAME}_FOUND FALSE) + set( ${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE "The following imported targets are referenced, but are missing: ${${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets}") + else() + message(FATAL_ERROR "The following imported targets are referenced, but are missing: ${${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets}") + endif() +endif() +unset(${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets) + +# Commands beyond this point should not need to know the version. +set(CMAKE_IMPORT_FILE_VERSION) +cmake_policy(POP) diff --git a/build/superlu/SRC/superlu_config.h b/build/superlu/SRC/superlu_config.h new file mode 100644 index 00000000..eeb2a1e4 --- /dev/null +++ b/build/superlu/SRC/superlu_config.h @@ -0,0 +1,24 @@ + +#ifndef SUPERLU_CONFIG_H +#define SUPERLU_CONFIG_H + +/* Enable metis */ +#define HAVE_METIS TRUE + +/* Enable colamd */ +/* #undef HAVE_COLAMD */ + +/* enable 64bit index mode */ +/* #undef XSDK_INDEX_SIZE */ + +/* Integer type for indexing sparse matrix meta structure */ +#if defined(XSDK_INDEX_SIZE) && (XSDK_INDEX_SIZE == 64) +#include +#define _LONGINT 1 +typedef int64_t int_t; +#else +typedef int int_t; /* default */ +#endif + +#endif /* SUPERLU_CONFIG_H */ + diff --git a/build/superlu/superlu.pc b/build/superlu/superlu.pc new file mode 100644 index 00000000..9a7be44e --- /dev/null +++ b/build/superlu/superlu.pc @@ -0,0 +1,12 @@ +prefix=/usr/local +libdir=/usr/local/lib +includedir=/usr/local/include + +Name: Mystran +Description: Direct solution of large, sparse systems of linear equations +Version: 7.0.1 +URL: https://portal.nersc.gov/project/sparse/superlu/ + +Libs: -L${libdir} -lsuperlu +Libs.private: blas -lm +Cflags: -I${includedir} diff --git a/dev_docs/lapack_unification_prompt.md b/dev_docs/lapack_unification_prompt.md deleted file mode 100644 index d35a2baf..00000000 --- a/dev_docs/lapack_unification_prompt.md +++ /dev/null @@ -1,204 +0,0 @@ -# LAPACK unification — follow-up agent prompt - -This document is the briefing for a future agent invocation that will -extend MYSTRAN's BLAS provider knob (`MYSTRAN_BLAS`) into a combined -`MYSTRAN_BLAS_LAPACK` knob, allowing MYSTRAN to use a system-provided -LAPACK (OpenBLAS / MKL / Netlib) instead of the embedded reference -implementations under `Source/Modules/LAPACK/`. - -The first half of the work — unifying BLAS — has already landed on the -`system_blas_fix` branch. This document captures everything the -follow-up agent needs to know about the LAPACK side so it does not have -to rediscover it. - ---- - -## Current state (post BLAS-only PR) - -- `MYSTRAN_BLAS={AUTO,SYSTEM,EMBEDDED}` is wired up in - [CMakeLists.txt](../CMakeLists.txt). It controls (a) whether - `BLAS/*.f` reference routines get bundled into mystran, (b) whether - SuperLU/SuperLU_MT build their own CBLAS, and (c) whether mystran is - linked against `${BLAS_LIBRARIES}`. -- Legacy `enable_internal_blaslib=YES/NO` still works and emits a - `DEPRECATION` warning that points at the new option. -- The build-info subroutines (`PRINT_BUILD_CONSTANTS`, - `PRINT_STATIC_LIB_LIST`) and the auto-generated license subroutines - read from the `_MYSTRAN_STATIC_DEFS` list and the - `_MYSTRAN_LICENSE_MAP`. `_STATIC_LAPACK` is currently force-appended - unconditionally — see the comment that explicitly flags it for this - follow-up. -- LAPACK is **always embedded**: every `Source/Modules/LAPACK/*.f` - module file is unconditionally compiled in via the - `file(GLOB_RECURSE ALL_FORTRAN_FILES ...)` in CMakeLists.txt. - ---- - -## Why LAPACK is harder than BLAS - -The embedded BLAS is **13 loose `.f` files** in `BLAS/`. Each defines -exactly one routine (e.g. `DGEMM.f` ⇒ `dgemm_`). They get included or -excluded as object files; system OpenBLAS provides identically-named -symbols, so all-or-nothing replacement at link time works trivially. - -The embedded LAPACK is **9 Fortran `MODULE`s** under -`Source/Modules/LAPACK/`, each containing many subroutines: - -| Module | Purpose | -|---|---| -| `LAPACK_BLAS_AUX` | Auxiliary routines used by other LAPACK code | -| `LAPACK_GIV_MGIV_EIG` | Generalised eigenvalue (Givens) helpers | -| `LAPACK_LANCZOS_EIG` | Lanczos eigenvalue helpers | -| `LAPACK_LIN_EQN_DGB` | General banded linear systems (DGBTRF/DGBTRS) | -| `LAPACK_LIN_EQN_DGE` | General dense linear systems (DGETRF/DGETRS) | -| `LAPACK_LIN_EQN_DPB` | Symmetric positive-definite banded | -| `LAPACK_MISCEL` | DSTEV, DSTERF, DSTEQR, DTRTRS | -| `LAPACK_STD_EIG_1` | DSYEV and friends | -| `LAPACK_SYM_MAT_INV` | DPOTRF/DPOTF2 | - -In total they define **95 procedures**. Because they are module -procedures, every consumer in the rest of MYSTRAN does -`USE LAPACK_` and the procedure references resolve at the -**source level** to module-mangled symbols -(`__lapack_blas_aux_MOD_dgemv` etc.). They never appear as bare -`dgemv_` symbols at link time and therefore *cannot* be silently -replaced by linking system LAPACK. - -There are roughly **70+ `USE LAPACK_*` sites** scattered across -`Source/`, including in the auto-generated `Source/Interfaces/*.f90` -files. - ---- - -## Routines that must stay embedded forever - -A grep of the module sources turns up at least four procedures that are -either MYSTRAN-specific or have non-standard signatures and have **no -direct system equivalent**: - -| Procedure | Reason | -|---|---| -| `DPTTRF_MYSTRAN` | MYSTRAN-specific name | -| `DSBGVX_GIV_MGIV` | Renamed/customized variant of LAPACK's `DSBGVX` | -| `DLACON(N, V, X, ISGN, EST, KASE, itmax)` | Extra `itmax` arg vs upstream `DLACON` | -| `EIGENVALUE_CONVERGENCE_FAILURE` | MYSTRAN error helper | - -Any other routines that have been locally patched (look for `! My ...` -comments and similar) need to stay too. **The audit below must -identify every such case.** - ---- - -## Recommended approach - -1. **Audit each of the 95 procedures** against the upstream Netlib - LAPACK reference (or whatever vintage of LAPACK these were copied - from — best guess from comments is LAPACK 3.x) and classify into: - - **Standard** — signature byte-for-byte identical to upstream - LAPACK. Safe to replace with an `INTERFACE` block in SYSTEM mode. - - **Custom** — different name, extra args, MYSTRAN error reporting, - or any other deviation. Must remain compiled in always. - Produce a Markdown table with one row per routine: name, module, - classification, notes. - -2. **Convert the 9 module files to use the C preprocessor.** They are - currently `.f` (no preprocessing). Either rename to `.F` or set - `set_source_files_properties(... PROPERTIES Fortran_PREPROCESS ON)`. - The codebase already uses uppercase `.F90` for some preprocessed - files, so renaming is consistent. - -3. **Restructure each module** as: - ```fortran - MODULE LAPACK_BLAS_AUX - ! ... existing USE statements ... - IMPLICIT NONE - #ifdef MYSTRAN_SYSTEM_LAPACK - INTERFACE - ! Explicit interface block per standard routine, copied - ! verbatim from netlib so INTENT/dimensions match exactly. - SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - ... - END SUBROUTINE DGEMV - ! ... - END INTERFACE - #endif - CONTAINS - #ifndef MYSTRAN_SYSTEM_LAPACK - ! All embedded standard-routine bodies. - #endif - ! Custom / always-compiled routines (DPTTRF_MYSTRAN, DLACON - ! with itmax, etc.) live outside the #ifdef and are always built. - END MODULE - ``` - -4. **CMake wiring** (small): - - Promote `MYSTRAN_BLAS` to `MYSTRAN_BLAS_LAPACK` (keep `MYSTRAN_BLAS` - as a deprecation alias the same way `enable_internal_blaslib` is - handled today). - - In SYSTEM mode also call `find_package(LAPACK)`; FATAL_ERROR if - missing. - - In SYSTEM mode: `target_compile_definitions(mystran PRIVATE - MYSTRAN_SYSTEM_LAPACK)` and append `${LAPACK_LIBRARIES}` to - `target_link_libraries(mystran ...)` (LAPACK before BLAS). - - Make `_STATIC_LAPACK` conditional on EMBEDDED mode (currently - unconditionally appended; the comment in CMakeLists.txt flags - this site explicitly). - - Restore the `_LAPACK_INFO` build-info field (it was added and - reverted during the BLAS-only PR — git log will show the diff). - - Update `BUILD.md` to describe the now-combined option and remove - the "LAPACK is always embedded" caveat. - -5. **Numerical regression testing.** Wrong INTENTs in interface blocks - produce silently wrong results. Run the full `Build_Test_Cases/` - statics + buckling + dynamics suite under both EMBEDDED and SYSTEM - modes and diff the outputs. Treat any diff beyond floating-point - noise as a bug in an interface block. - ---- - -## Key files / starting points - -- [CMakeLists.txt](../CMakeLists.txt) — search for - `MYSTRAN_BLAS`, `_MYSTRAN_BLAS_MODE`, `_STATIC_LAPACK`, `_BLAS_INFO`. -- [Source/Modules/LAPACK/](../Source/Modules/LAPACK) — the 9 files to - restructure. -- [BLAS/](../BLAS) — pattern for what loose-file standard routines look - like (this directory is *not* affected by the LAPACK work). -- [Source/MAIN/PRINT_BUILD_INFO.F90](../Source/MAIN/PRINT_BUILD_INFO.F90) - — already keys off `_STATIC_*` macros; nothing to change here. -- [BUILD.md](../BUILD.md) — user-facing docs. - -To enumerate every consumer: - -```bash -grep -rE '^\s+USE\s+LAPACK_' Source/ | sort -u -``` - -To list every procedure declared in the embedded modules: - -```bash -cd Source/Modules/LAPACK -grep -hE '^\s+(SUBROUTINE|.*FUNCTION)\s+[A-Z_][A-Z0-9_]*' *.f | sort -u -``` - ---- - -## Test environment - -- Linux dev machine has OpenBLAS at `/usr/lib/libopenblas.so` which - exposes the LAPACK API. `find_package(LAPACK)` succeeds out of the - box and reports `LAPACK_LIBRARIES = /usr/lib/libopenblas.so;-lm;-ldl`. -- Windows MSYS2 / MinGW64: `pacman -S mingw-w64-x86_64-openblas` - installs a static OpenBLAS that also covers LAPACK. - ---- - -## Decisions inherited from the BLAS-only PR - -- All-or-nothing replacement (no per-routine fallback). LAPACK follows - the same model — but "all" excludes the always-custom routines - enumerated above. -- Detection via `find_package(LAPACK)`, no symbol probing. -- Windows static-binary support is non-negotiable; OpenBLAS static - archive is the recommended provider. -- Legacy CMake flags get deprecation warnings, not removal. From fbdf441e26f1be04d25e2a9dea4828f4710b9af1 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Wed, 27 May 2026 23:30:06 -0300 Subject: [PATCH 03/11] tidying up submodules and adding licenses --- .gitignore | 3 + .gitmodules | 10 +- CMakeLists.txt | 138 +++++++++++++++--- build/CPackConfig.cmake | 70 --------- build/CPackSourceConfig.cmake | 76 ---------- build/superlu/FORTRAN/superlu_config.h | 24 --- build/superlu/SRC/superluConfig.cmake | 39 ----- build/superlu/SRC/superluConfigVersion.cmake | 65 --------- build/superlu/SRC/superluTargets.cmake | 85 ----------- build/superlu/SRC/superlu_config.h | 24 --- build/superlu/superlu.pc | 12 -- extra_licenses/atlas.txt | 26 ++++ extra_licenses/blis.txt | 46 ++++++ extra_licenses/mkl.txt | 69 +++++++++ ...blas-lapack.txt => netlib-blas-lapack.txt} | 0 extra_licenses/openblas.txt | 29 ++++ {metis => submodules}/GKlib | 0 .../gklib_patches/CMakeLists.txt | 0 {Source => submodules}/lapack | 0 .../CMAKE/PreventInSourceBuilds.cmake | 12 ++ metis/METIS => submodules/metis | 0 .../metis_patches/CMakeLists.txt | 0 superlu => submodules/superlu | 0 superlu_mt => submodules/superlu_mt | 0 .../superlu_mt_patches}/CMakeLists.txt | 16 +- .../superlu_mt_patches}/SRC/CMakeLists.txt | 0 .../SRC/c_fortran_pdgssv.c | 0 .../superlu_mt_patches}/SRC/get_perm_c.c | 0 .../superlu_mt_patches}/SRC/pmemory.c | 0 .../superlu_mt_patches}/SRC/sp_ienv.c | 0 .../superlu_patches}/CMakeLists.txt | 16 +- .../FORTRAN/c_fortran_dgssv.c | 0 superlu_mt_patches/CBLAS/CMakeLists.txt | 98 ------------- 33 files changed, 319 insertions(+), 539 deletions(-) delete mode 100644 build/CPackConfig.cmake delete mode 100644 build/CPackSourceConfig.cmake delete mode 100644 build/superlu/FORTRAN/superlu_config.h delete mode 100644 build/superlu/SRC/superluConfig.cmake delete mode 100644 build/superlu/SRC/superluConfigVersion.cmake delete mode 100644 build/superlu/SRC/superluTargets.cmake delete mode 100644 build/superlu/SRC/superlu_config.h delete mode 100644 build/superlu/superlu.pc create mode 100644 extra_licenses/atlas.txt create mode 100644 extra_licenses/blis.txt create mode 100644 extra_licenses/mkl.txt rename extra_licenses/{blas-lapack.txt => netlib-blas-lapack.txt} (100%) create mode 100644 extra_licenses/openblas.txt rename {metis => submodules}/GKlib (100%) rename {metis => submodules}/gklib_patches/CMakeLists.txt (100%) rename {Source => submodules}/lapack (100%) create mode 100644 submodules/lapack_patches/CMAKE/PreventInSourceBuilds.cmake rename metis/METIS => submodules/metis (100%) rename {metis => submodules}/metis_patches/CMakeLists.txt (100%) rename superlu => submodules/superlu (100%) rename superlu_mt => submodules/superlu_mt (100%) rename {superlu_mt_patches => submodules/superlu_mt_patches}/CMakeLists.txt (91%) rename {superlu_mt_patches => submodules/superlu_mt_patches}/SRC/CMakeLists.txt (100%) rename {superlu_mt_patches => submodules/superlu_mt_patches}/SRC/c_fortran_pdgssv.c (100%) rename {superlu_mt_patches => submodules/superlu_mt_patches}/SRC/get_perm_c.c (100%) rename {superlu_mt_patches => submodules/superlu_mt_patches}/SRC/pmemory.c (100%) rename {superlu_mt_patches => submodules/superlu_mt_patches}/SRC/sp_ienv.c (100%) rename {superlu_patches => submodules/superlu_patches}/CMakeLists.txt (95%) rename {superlu_patches => submodules/superlu_patches}/FORTRAN/c_fortran_dgssv.c (100%) delete mode 100644 superlu_mt_patches/CBLAS/CMakeLists.txt diff --git a/.gitignore b/.gitignore index 67218f60..f0222fff 100644 --- a/.gitignore +++ b/.gitignore @@ -40,3 +40,6 @@ fort.* # generated subroutines Source/INCLUDE/*.F90.inc + +# CPack stuff (for in-source LAPACK builds) +CPack*.cmake diff --git a/.gitmodules b/.gitmodules index 7f0360e0..a75e30cd 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,28 +1,28 @@ [submodule "superlu"] - path = superlu + path = submodules/superlu url = https://github.com/xiaoyeli/superlu ignore = all update = checkout branch = master [submodule "superlu_mt"] - path = superlu_mt + path = submodules/superlu_mt url = https://github.com/xiaoyeli/superlu_mt ignore = all update = checkout branch = master [submodule "metis/GKlib"] - path = metis/GKlib + path = submodules/GKlib url = https://github.com/KarypisLab/GKlib.git ignore = all update = checkout branch = master [submodule "metis/METIS"] - path = metis/METIS + path = submodules/metis url = https://github.com/KarypisLab/METIS.git ignore = all update = checkout branch = master [submodule "Source/lapack"] - path = Source/lapack + path = submodules/lapack url = https://github.com/Reference-LAPACK/lapack.git diff --git a/CMakeLists.txt b/CMakeLists.txt index 05cf2714..7b47550c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -81,14 +81,17 @@ if(GIT_FOUND AND EXISTS "${PROJECT_SOURCE_DIR}/.git") endif() endif() -set(SUPERLU_DIR "${PROJECT_SOURCE_DIR}/superlu") -set(SUPERLU_PATCHES_DIR "${PROJECT_SOURCE_DIR}/superlu_patches") -set(SUPERLU_MT_DIR "${PROJECT_SOURCE_DIR}/superlu_mt") -set(SUPERLU_MT_PATCHES_DIR "${PROJECT_SOURCE_DIR}/superlu_mt_patches") -set(METIS_DIR "${PROJECT_SOURCE_DIR}/metis/METIS") -set(GKLIB_DIR "${PROJECT_SOURCE_DIR}/metis/GKlib") -set(METIS_PATCHES_DIR "${PROJECT_SOURCE_DIR}/metis/metis_patches") -set(GKLIB_PATCHES_DIR "${PROJECT_SOURCE_DIR}/metis/gklib_patches") +# All git submodules and their patch overlays live under submodules/. +set(SUBMODULES_DIR "${PROJECT_SOURCE_DIR}/submodules") +set(SUPERLU_DIR "${SUBMODULES_DIR}/superlu") +set(SUPERLU_PATCHES_DIR "${SUBMODULES_DIR}/superlu_patches") +set(SUPERLU_MT_DIR "${SUBMODULES_DIR}/superlu_mt") +set(SUPERLU_MT_PATCHES_DIR "${SUBMODULES_DIR}/superlu_mt_patches") +set(METIS_DIR "${SUBMODULES_DIR}/metis") +set(GKLIB_DIR "${SUBMODULES_DIR}/GKlib") +set(METIS_PATCHES_DIR "${SUBMODULES_DIR}/metis_patches") +set(GKLIB_PATCHES_DIR "${SUBMODULES_DIR}/gklib_patches") +set(MYSTRAN_LAPACK_DIR "${SUBMODULES_DIR}/lapack") if(NOT DEFINED TPL_ENABLE_METISLIB) set(TPL_ENABLE_METISLIB ON CACHE BOOL "Enable METIS for SuperLU") @@ -270,14 +273,29 @@ endif() # submodule under Source/lapack. Configure it as a quiet, minimal, # static-only sub-build before any add_subdirectory() that consumes it. if(_MYSTRAN_BLAS_LAPACK_MODE STREQUAL "EMBEDDED") - set(MYSTRAN_LAPACK_DIR "${PROJECT_SOURCE_DIR}/Source/lapack") - if(NOT EXISTS "${MYSTRAN_LAPACK_DIR}/CMakeLists.txt") message(FATAL_ERROR "The Reference-LAPACK submodule was not downloaded. " "Run: git submodule update --init --recursive") endif() + set(LAPACK_PATCHES_DIR "${SUBMODULES_DIR}/lapack_patches") + message(STATUS "Applying patches to Reference-LAPACK...") + file(GLOB_RECURSE LAPACK_PATCH_FILES RELATIVE "${LAPACK_PATCHES_DIR}" "${LAPACK_PATCHES_DIR}/*") + + foreach(file IN LISTS LAPACK_PATCH_FILES) + set(src "${LAPACK_PATCHES_DIR}/${file}") + set(dst "${MYSTRAN_LAPACK_DIR}/${file}") + + get_filename_component(dst_dir "${dst}" DIRECTORY) + file(MAKE_DIRECTORY "${dst_dir}") + + message(STATUS " Patching: ${file}") + file(COPY "${src}" DESTINATION "${dst_dir}") + endforeach() + + message(STATUS "Reference-LAPACK patched.") + # Only build what MYSTRAN actually uses: double-precision real BLAS # and LAPACK. Everything else off. set(BUILD_SHARED_LIBS OFF CACHE BOOL "" FORCE) @@ -498,11 +516,6 @@ file(GLOB_RECURSE ALL_FORTRAN_FILES "${CMAKE_SOURCE_DIR}/*.F03" ) -# Exclude the Reference-LAPACK submodule from the mystran source list. -# Its Fortran files live under Source/lapack/ but are compiled by the -# submodule's own CMake project (when EMBEDDED), not by mystran. -list(FILTER ALL_FORTRAN_FILES EXCLUDE REGEX "${CMAKE_SOURCE_DIR}/lapack/") - # prepare the main executable, linked against the specifics and the m # it appears utils used to be a module, but that is no longer the case? # file(GLOB UTIL_FILES "${CMAKE_SOURCE_DIR}/UTIL/*.f*") @@ -602,13 +615,80 @@ if(TPL_ENABLE_METISLIB) endif() endif() -# In EMBEDDED mode, the Reference-LAPACK submodule provides static -# libblas.a and liblapack.a archives that get linked into the binary. +# BLAS/LAPACK provider tracking. +# +# EMBEDDED: the Reference-LAPACK submodule provides static libblas.a +# and liblapack.a archives, and its own LICENSE is bundled. +# SYSTEM: we statically link a system BLAS+LAPACK. We try to detect +# the vendor (OpenBLAS, MKL, BLIS, ATLAS, Apple Accelerate, +# Arm Performance Libraries) from BLAS_LIBRARIES/LAPACK_LIBRARIES +# so the corresponding license text from extra_licenses/ can +# be embedded in the binary. If detection fails OR the license +# file is missing, we WARN the user that the resulting binary +# may not be legally redistributable. +set(_SYS_BLAS_TAG "") +set(_SYS_BLAS_LIBNAME "") +set(_SYS_BLAS_DESC "") +set(_SYS_BLAS_LICENSE_PATH "") + if(_MYSTRAN_BLAS_LAPACK_MODE STREQUAL "EMBEDDED") list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_BLAS) list(APPEND _MYSTRAN_STATIC_NAMES libblas.a) list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_LAPACK) list(APPEND _MYSTRAN_STATIC_NAMES liblapack.a) +else() + # Use the concatenated link-line strings as the signature to match. + string(TOLOWER "${BLAS_LIBRARIES};${LAPACK_LIBRARIES}" _SYS_BLAS_SIG) + + if(_SYS_BLAS_SIG MATCHES "openblas") + set(_SYS_BLAS_TAG "OPENBLAS") + set(_SYS_BLAS_LIBNAME "OpenBLAS") + set(_SYS_BLAS_DESC "system BLAS+LAPACK") + set(_SYS_BLAS_LICENSE_PATH "extra_licenses/openblas.txt") + elseif(_SYS_BLAS_SIG MATCHES "mkl") + set(_SYS_BLAS_TAG "MKL") + set(_SYS_BLAS_LIBNAME "Intel MKL") + set(_SYS_BLAS_DESC "system BLAS+LAPACK") + set(_SYS_BLAS_LICENSE_PATH "extra_licenses/mkl.txt") + elseif(_SYS_BLAS_SIG MATCHES "blis") + set(_SYS_BLAS_TAG "BLIS") + set(_SYS_BLAS_LIBNAME "BLIS") + set(_SYS_BLAS_DESC "system BLAS") + set(_SYS_BLAS_LICENSE_PATH "extra_licenses/blis.txt") + elseif(_SYS_BLAS_SIG MATCHES "atlas") + set(_SYS_BLAS_TAG "ATLAS") + set(_SYS_BLAS_LIBNAME "ATLAS") + set(_SYS_BLAS_DESC "system BLAS+LAPACK") + set(_SYS_BLAS_LICENSE_PATH "extra_licenses/atlas.txt") + elseif(_SYS_BLAS_SIG MATCHES "blas") + # Generic Reference-BLAS / netlib install on the system. + set(_SYS_BLAS_TAG "REFBLAS") + set(_SYS_BLAS_LIBNAME "Reference BLAS/LAPACK") + set(_SYS_BLAS_DESC "system BLAS+LAPACK (Reference-LAPACK / netlib)") + set(_SYS_BLAS_LICENSE_PATH "extra_licenses/netlib-blas-lapack.txt") + endif() + + if(_SYS_BLAS_TAG STREQUAL "") + message(WARNING + "Could not identify the system BLAS/LAPACK vendor from " + "BLAS_LIBRARIES='${BLAS_LIBRARIES}', LAPACK_LIBRARIES='${LAPACK_LIBRARIES}'.\n" + " No license text will be embedded for the BLAS/LAPACK provider, " + "which may make the resulting binary legally undistributable.\n" + " Add a matching entry to the system-BLAS detection block in " + "CMakeLists.txt and drop the license file under extra_licenses/.") + else() + list(APPEND _MYSTRAN_STATIC_DEFS "_STATIC_${_SYS_BLAS_TAG}") + list(APPEND _MYSTRAN_STATIC_NAMES "${_SYS_BLAS_LIBNAME}") + + if(NOT EXISTS "${PROJECT_SOURCE_DIR}/${_SYS_BLAS_LICENSE_PATH}") + message(WARNING + "System BLAS/LAPACK detected as ${_SYS_BLAS_LIBNAME}, but the " + "expected license file is missing:\n" + " ${PROJECT_SOURCE_DIR}/${_SYS_BLAS_LICENSE_PATH}\n" + " The binary will be built without an embedded license for " + "${_SYS_BLAS_LIBNAME}, which may make it legally undistributable.") + endif() + endif() endif() # On Windows the -static linker flag pulls in Fortran and C runtimes too @@ -644,12 +724,10 @@ list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_ARPACK) # ----------------------------------------------------------------------- set(_MYSTRAN_LICENSE_MAP "F2C:f2c/Notice:libf2c:Fortran-to-C runtime support library" - "SUPERLU:superlu/License.txt:SuperLU:sparse solver" - "SUPERLU_MT:superlu_mt/License.txt:SuperLU_MT:multi-threaded sparse solver" - "METIS:metis/METIS/LICENSE:METIS:graph partitioner for SuperLU" - "GKLIB:metis/GKlib/LICENSE.txt:GKlib:utility library for METIS" - "BLAS:extra_licenses/blas-lapack.txt:BLAS:embedded subset of reference BLAS" - "LAPACK:extra_licenses/blas-lapack.txt:LAPACK:linear algebra library" + "SUPERLU:submodules/superlu/License.txt:SuperLU:sparse solver" + "SUPERLU_MT:submodules/superlu_mt/License.txt:SuperLU_MT:multi-threaded sparse solver" + "METIS:submodules/metis/LICENSE:METIS:graph partitioner for SuperLU" + "GKLIB:submodules/GKlib/LICENSE.txt:GKlib:utility library for METIS" "ARPACK:extra_licenses/arpack.txt:ARPACK:Lanczos eigensolver implementation" "GOMP:extra_licenses/gpl-3.0-with-gcc-exception.txt:libgomp:GNU OpenMP runtime" "GFORTRAN:extra_licenses/gpl-3.0-with-gcc-exception.txt:libgfortran:GNU Fortran runtime" @@ -659,6 +737,20 @@ set(_MYSTRAN_LICENSE_MAP "REGEX:extra_licenses/lgpl-2.1.txt:libregex:POSIX regexes, used by GKlib" ) +# BLAS/LAPACK license entry depends on which provider was selected. +# EMBEDDED -> Reference-LAPACK submodule ships its own LICENSE. +# SYSTEM -> use the detected vendor's license file, if known. +if(_MYSTRAN_BLAS_LAPACK_MODE STREQUAL "EMBEDDED") + list(APPEND _MYSTRAN_LICENSE_MAP + "BLAS:submodules/lapack/LICENSE:BLAS:Reference-LAPACK submodule (embedded BLAS)" + "LAPACK:submodules/lapack/LICENSE:LAPACK:Reference-LAPACK submodule (embedded LAPACK)" + ) +elseif(NOT _SYS_BLAS_TAG STREQUAL "") + list(APPEND _MYSTRAN_LICENSE_MAP + "${_SYS_BLAS_TAG}:${_SYS_BLAS_LICENSE_PATH}:${_SYS_BLAS_LIBNAME}:${_SYS_BLAS_DESC}" + ) +endif() + # Generate STATIC_LICENSES_GENERATED.F90 in the build directory set(_GEN_LIC_FILE "${CMAKE_SOURCE_DIR}/INCLUDE/STATIC_LICENSES_GENERATED.F90.inc") set(_GEN_LIC_CONTENT "! AUTO-GENERATED by CMakeLists.txt -- DO NOT EDIT\n") diff --git a/build/CPackConfig.cmake b/build/CPackConfig.cmake deleted file mode 100644 index c3d252c3..00000000 --- a/build/CPackConfig.cmake +++ /dev/null @@ -1,70 +0,0 @@ -# This file will be configured to contain variables for CPack. These variables -# should be set in the CMake list file of the project before CPack module is -# included. The list of available CPACK_xxx variables and their associated -# documentation may be obtained using -# cpack --help-variable-list -# -# Some variables are common to all generators (e.g. CPACK_PACKAGE_NAME) -# and some are specific to a generator -# (e.g. CPACK_NSIS_EXTRA_INSTALL_COMMANDS). The generator specific variables -# usually begin with CPACK__xxxx. - - -set(CPACK_ARCHIVE_GID "-1") -set(CPACK_ARCHIVE_UID "-1") -set(CPACK_BUILD_SOURCE_DIRS "/home/bruno/Git/MYSTRAN;/home/bruno/Git/MYSTRAN/build") -set(CPACK_CMAKE_GENERATOR "Ninja") -set(CPACK_COMPONENT_UNSPECIFIED_HIDDEN "TRUE") -set(CPACK_COMPONENT_UNSPECIFIED_REQUIRED "TRUE") -set(CPACK_DEFAULT_PACKAGE_DESCRIPTION_FILE "/usr/share/cmake/Templates/CPack.GenericDescription.txt") -set(CPACK_DEFAULT_PACKAGE_DESCRIPTION_SUMMARY "Mystran built using CMake") -set(CPACK_DMG_SLA_USE_RESOURCE_FILE_LICENSE "ON") -set(CPACK_GENERATOR "TGZ") -set(CPACK_INNOSETUP_ARCHITECTURE "x64") -set(CPACK_INSTALL_CMAKE_PROJECTS "/home/bruno/Git/MYSTRAN/build;Mystran;ALL;/") -set(CPACK_INSTALL_PREFIX "/usr/local") -set(CPACK_MODULE_PATH "/home/bruno/Git/MYSTRAN/Source/lapack/CMAKE") -set(CPACK_MONOLITHIC_INSTALL "ON") -set(CPACK_NSIS_DISPLAY_NAME "LAPACK") -set(CPACK_NSIS_INSTALLER_ICON_CODE "") -set(CPACK_NSIS_INSTALLER_MUI_ICON_CODE "") -set(CPACK_NSIS_INSTALL_ROOT "$PROGRAMFILES") -set(CPACK_NSIS_PACKAGE_NAME "LAPACK") -set(CPACK_NSIS_UNINSTALL_NAME "Uninstall") -set(CPACK_OBJCOPY_EXECUTABLE "/usr/bin/objcopy") -set(CPACK_OBJDUMP_EXECUTABLE "/usr/bin/objdump") -set(CPACK_OUTPUT_CONFIG_FILE "/home/bruno/Git/MYSTRAN/build/CPackConfig.cmake") -set(CPACK_PACKAGE_DEFAULT_LOCATION "/") -set(CPACK_PACKAGE_DESCRIPTION_FILE "/usr/share/cmake/Templates/CPack.GenericDescription.txt") -set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "LAPACK- Linear Algebra Package") -set(CPACK_PACKAGE_FILE_NAME "LAPACK-3.12.1-Linux") -set(CPACK_PACKAGE_INSTALL_DIRECTORY "LAPACK") -set(CPACK_PACKAGE_INSTALL_REGISTRY_KEY "LAPACK") -set(CPACK_PACKAGE_NAME "LAPACK") -set(CPACK_PACKAGE_RELOCATABLE "true") -set(CPACK_PACKAGE_VENDOR "University of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd") -set(CPACK_PACKAGE_VERSION "3.12.1") -set(CPACK_PACKAGE_VERSION_MAJOR "3") -set(CPACK_PACKAGE_VERSION_MINOR "12") -set(CPACK_PACKAGE_VERSION_PATCH "1") -set(CPACK_READELF_EXECUTABLE "/usr/bin/readelf") -set(CPACK_RESOURCE_FILE_LICENSE "/home/bruno/Git/MYSTRAN/Source/lapack/LICENSE") -set(CPACK_RESOURCE_FILE_README "/usr/share/cmake/Templates/CPack.GenericDescription.txt") -set(CPACK_RESOURCE_FILE_WELCOME "/usr/share/cmake/Templates/CPack.GenericWelcome.txt") -set(CPACK_SET_DESTDIR "OFF") -set(CPACK_SOURCE_GENERATOR "TGZ") -set(CPACK_SOURCE_IGNORE_FILES "~$;.svn") -set(CPACK_SOURCE_OUTPUT_CONFIG_FILE "/home/bruno/Git/MYSTRAN/build/CPackSourceConfig.cmake") -set(CPACK_SOURCE_PACKAGE_FILE_NAME "lapack-3.12.1") -set(CPACK_SYSTEM_NAME "Linux") -set(CPACK_THREADS "1") -set(CPACK_TOPLEVEL_TAG "Linux") -set(CPACK_WIX_SIZEOF_VOID_P "8") - -if(NOT CPACK_PROPERTIES_FILE) - set(CPACK_PROPERTIES_FILE "/home/bruno/Git/MYSTRAN/build/CPackProperties.cmake") -endif() - -if(EXISTS ${CPACK_PROPERTIES_FILE}) - include(${CPACK_PROPERTIES_FILE}) -endif() diff --git a/build/CPackSourceConfig.cmake b/build/CPackSourceConfig.cmake deleted file mode 100644 index a68d6dc5..00000000 --- a/build/CPackSourceConfig.cmake +++ /dev/null @@ -1,76 +0,0 @@ -# This file will be configured to contain variables for CPack. These variables -# should be set in the CMake list file of the project before CPack module is -# included. The list of available CPACK_xxx variables and their associated -# documentation may be obtained using -# cpack --help-variable-list -# -# Some variables are common to all generators (e.g. CPACK_PACKAGE_NAME) -# and some are specific to a generator -# (e.g. CPACK_NSIS_EXTRA_INSTALL_COMMANDS). The generator specific variables -# usually begin with CPACK__xxxx. - - -set(CPACK_ARCHIVE_GID "-1") -set(CPACK_ARCHIVE_UID "-1") -set(CPACK_BUILD_SOURCE_DIRS "/home/bruno/Git/MYSTRAN;/home/bruno/Git/MYSTRAN/build") -set(CPACK_CMAKE_GENERATOR "Ninja") -set(CPACK_COMPONENT_UNSPECIFIED_HIDDEN "TRUE") -set(CPACK_COMPONENT_UNSPECIFIED_REQUIRED "TRUE") -set(CPACK_DEFAULT_PACKAGE_DESCRIPTION_FILE "/usr/share/cmake/Templates/CPack.GenericDescription.txt") -set(CPACK_DEFAULT_PACKAGE_DESCRIPTION_SUMMARY "Mystran built using CMake") -set(CPACK_DMG_SLA_USE_RESOURCE_FILE_LICENSE "ON") -set(CPACK_GENERATOR "TGZ") -set(CPACK_IGNORE_FILES "~$;.svn") -set(CPACK_INNOSETUP_ARCHITECTURE "x64") -set(CPACK_INSTALLED_DIRECTORIES "/home/bruno/Git/MYSTRAN;/") -set(CPACK_INSTALL_CMAKE_PROJECTS "") -set(CPACK_INSTALL_PREFIX "/usr/local") -set(CPACK_MODULE_PATH "/home/bruno/Git/MYSTRAN/Source/lapack/CMAKE") -set(CPACK_MONOLITHIC_INSTALL "ON") -set(CPACK_NSIS_DISPLAY_NAME "LAPACK") -set(CPACK_NSIS_INSTALLER_ICON_CODE "") -set(CPACK_NSIS_INSTALLER_MUI_ICON_CODE "") -set(CPACK_NSIS_INSTALL_ROOT "$PROGRAMFILES") -set(CPACK_NSIS_PACKAGE_NAME "LAPACK") -set(CPACK_NSIS_UNINSTALL_NAME "Uninstall") -set(CPACK_OBJCOPY_EXECUTABLE "/usr/bin/objcopy") -set(CPACK_OBJDUMP_EXECUTABLE "/usr/bin/objdump") -set(CPACK_OUTPUT_CONFIG_FILE "/home/bruno/Git/MYSTRAN/build/CPackConfig.cmake") -set(CPACK_PACKAGE_DEFAULT_LOCATION "/") -set(CPACK_PACKAGE_DESCRIPTION_FILE "/usr/share/cmake/Templates/CPack.GenericDescription.txt") -set(CPACK_PACKAGE_DESCRIPTION_SUMMARY "LAPACK- Linear Algebra Package") -set(CPACK_PACKAGE_FILE_NAME "lapack-3.12.1") -set(CPACK_PACKAGE_INSTALL_DIRECTORY "LAPACK") -set(CPACK_PACKAGE_INSTALL_REGISTRY_KEY "LAPACK") -set(CPACK_PACKAGE_NAME "LAPACK") -set(CPACK_PACKAGE_RELOCATABLE "true") -set(CPACK_PACKAGE_VENDOR "University of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd") -set(CPACK_PACKAGE_VERSION "3.12.1") -set(CPACK_PACKAGE_VERSION_MAJOR "3") -set(CPACK_PACKAGE_VERSION_MINOR "12") -set(CPACK_PACKAGE_VERSION_PATCH "1") -set(CPACK_READELF_EXECUTABLE "/usr/bin/readelf") -set(CPACK_RESOURCE_FILE_LICENSE "/home/bruno/Git/MYSTRAN/Source/lapack/LICENSE") -set(CPACK_RESOURCE_FILE_README "/usr/share/cmake/Templates/CPack.GenericDescription.txt") -set(CPACK_RESOURCE_FILE_WELCOME "/usr/share/cmake/Templates/CPack.GenericWelcome.txt") -set(CPACK_RPM_PACKAGE_SOURCES "ON") -set(CPACK_SET_DESTDIR "OFF") -set(CPACK_SOURCE_GENERATOR "TGZ") -set(CPACK_SOURCE_IGNORE_FILES "~$;.svn") -set(CPACK_SOURCE_INSTALLED_DIRECTORIES "/home/bruno/Git/MYSTRAN;/") -set(CPACK_SOURCE_OUTPUT_CONFIG_FILE "/home/bruno/Git/MYSTRAN/build/CPackSourceConfig.cmake") -set(CPACK_SOURCE_PACKAGE_FILE_NAME "lapack-3.12.1") -set(CPACK_SOURCE_TOPLEVEL_TAG "Linux-Source") -set(CPACK_STRIP_FILES "") -set(CPACK_SYSTEM_NAME "Linux") -set(CPACK_THREADS "1") -set(CPACK_TOPLEVEL_TAG "Linux-Source") -set(CPACK_WIX_SIZEOF_VOID_P "8") - -if(NOT CPACK_PROPERTIES_FILE) - set(CPACK_PROPERTIES_FILE "/home/bruno/Git/MYSTRAN/build/CPackProperties.cmake") -endif() - -if(EXISTS ${CPACK_PROPERTIES_FILE}) - include(${CPACK_PROPERTIES_FILE}) -endif() diff --git a/build/superlu/FORTRAN/superlu_config.h b/build/superlu/FORTRAN/superlu_config.h deleted file mode 100644 index eeb2a1e4..00000000 --- a/build/superlu/FORTRAN/superlu_config.h +++ /dev/null @@ -1,24 +0,0 @@ - -#ifndef SUPERLU_CONFIG_H -#define SUPERLU_CONFIG_H - -/* Enable metis */ -#define HAVE_METIS TRUE - -/* Enable colamd */ -/* #undef HAVE_COLAMD */ - -/* enable 64bit index mode */ -/* #undef XSDK_INDEX_SIZE */ - -/* Integer type for indexing sparse matrix meta structure */ -#if defined(XSDK_INDEX_SIZE) && (XSDK_INDEX_SIZE == 64) -#include -#define _LONGINT 1 -typedef int64_t int_t; -#else -typedef int int_t; /* default */ -#endif - -#endif /* SUPERLU_CONFIG_H */ - diff --git a/build/superlu/SRC/superluConfig.cmake b/build/superlu/SRC/superluConfig.cmake deleted file mode 100644 index 440cc4a4..00000000 --- a/build/superlu/SRC/superluConfig.cmake +++ /dev/null @@ -1,39 +0,0 @@ - -####### Expanded from @PACKAGE_INIT@ by configure_package_config_file() ####### -####### Any changes to this file will be overwritten by the next CMake run #### -####### The input file was superluConfig.cmake.in ######## - -get_filename_component(PACKAGE_PREFIX_DIR "${CMAKE_CURRENT_LIST_DIR}/../../../../../../../../usr/local" ABSOLUTE) - -macro(set_and_check _var _file) - set(${_var} "${_file}") - if(NOT EXISTS "${_file}") - message(FATAL_ERROR "File or directory ${_file} referenced by variable ${_var} does not exist !") - endif() -endmacro() - -macro(check_required_components _NAME) - foreach(comp ${${_NAME}_FIND_COMPONENTS}) - if(NOT ${_NAME}_${comp}_FOUND) - if(${_NAME}_FIND_REQUIRED_${comp}) - set(${_NAME}_FOUND FALSE) - endif() - endif() - endforeach() -endmacro() - -#################################################################################### - -include(CMakeFindDependencyMacro) - -set(enable_blaslib ) - -list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}") - -if(NOT enable_blaslib) - find_dependency(BLAS) -else() - include("${CMAKE_CURRENT_LIST_DIR}/blasTargets.cmake") -endif() - -include("${CMAKE_CURRENT_LIST_DIR}/superluTargets.cmake") diff --git a/build/superlu/SRC/superluConfigVersion.cmake b/build/superlu/SRC/superluConfigVersion.cmake deleted file mode 100644 index 29367693..00000000 --- a/build/superlu/SRC/superluConfigVersion.cmake +++ /dev/null @@ -1,65 +0,0 @@ -# This is a basic version file for the Config-mode of find_package(). -# It is used by write_basic_package_version_file() as input file for configure_file() -# to create a version-file which can be installed along a config.cmake file. -# -# The created file sets PACKAGE_VERSION_EXACT if the current version string and -# the requested version string are exactly the same and it sets -# PACKAGE_VERSION_COMPATIBLE if the current version is >= requested version, -# but only if the requested major version is the same as the current one. -# The variable CVF_VERSION must be set before calling configure_file(). - - -set(PACKAGE_VERSION "7.0.1") - -if(PACKAGE_VERSION VERSION_LESS PACKAGE_FIND_VERSION) - set(PACKAGE_VERSION_COMPATIBLE FALSE) -else() - - if("7.0.1" MATCHES "^([0-9]+)\\.") - set(CVF_VERSION_MAJOR "${CMAKE_MATCH_1}") - if(NOT CVF_VERSION_MAJOR VERSION_EQUAL 0) - string(REGEX REPLACE "^0+" "" CVF_VERSION_MAJOR "${CVF_VERSION_MAJOR}") - endif() - else() - set(CVF_VERSION_MAJOR "7.0.1") - endif() - - if(PACKAGE_FIND_VERSION_RANGE) - # both endpoints of the range must have the expected major version - math (EXPR CVF_VERSION_MAJOR_NEXT "${CVF_VERSION_MAJOR} + 1") - if (NOT PACKAGE_FIND_VERSION_MIN_MAJOR STREQUAL CVF_VERSION_MAJOR - OR ((PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "INCLUDE" AND NOT PACKAGE_FIND_VERSION_MAX_MAJOR STREQUAL CVF_VERSION_MAJOR) - OR (PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "EXCLUDE" AND NOT PACKAGE_FIND_VERSION_MAX VERSION_LESS_EQUAL CVF_VERSION_MAJOR_NEXT))) - set(PACKAGE_VERSION_COMPATIBLE FALSE) - elseif(PACKAGE_FIND_VERSION_MIN_MAJOR STREQUAL CVF_VERSION_MAJOR - AND ((PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "INCLUDE" AND PACKAGE_VERSION VERSION_LESS_EQUAL PACKAGE_FIND_VERSION_MAX) - OR (PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "EXCLUDE" AND PACKAGE_VERSION VERSION_LESS PACKAGE_FIND_VERSION_MAX))) - set(PACKAGE_VERSION_COMPATIBLE TRUE) - else() - set(PACKAGE_VERSION_COMPATIBLE FALSE) - endif() - else() - if(PACKAGE_FIND_VERSION_MAJOR STREQUAL CVF_VERSION_MAJOR) - set(PACKAGE_VERSION_COMPATIBLE TRUE) - else() - set(PACKAGE_VERSION_COMPATIBLE FALSE) - endif() - - if(PACKAGE_FIND_VERSION STREQUAL PACKAGE_VERSION) - set(PACKAGE_VERSION_EXACT TRUE) - endif() - endif() -endif() - - -# if the installed or the using project don't have CMAKE_SIZEOF_VOID_P set, ignore it: -if("${CMAKE_SIZEOF_VOID_P}" STREQUAL "" OR "8" STREQUAL "") - return() -endif() - -# check that the installed version has the same 32/64bit-ness as the one which is currently searching: -if(NOT CMAKE_SIZEOF_VOID_P STREQUAL "8") - math(EXPR installedBits "8 * 8") - set(PACKAGE_VERSION "${PACKAGE_VERSION} (${installedBits}bit)") - set(PACKAGE_VERSION_UNSUITABLE TRUE) -endif() diff --git a/build/superlu/SRC/superluTargets.cmake b/build/superlu/SRC/superluTargets.cmake deleted file mode 100644 index ad47c3a3..00000000 --- a/build/superlu/SRC/superluTargets.cmake +++ /dev/null @@ -1,85 +0,0 @@ -# Generated by CMake - -if("${CMAKE_MAJOR_VERSION}.${CMAKE_MINOR_VERSION}" LESS 2.8) - message(FATAL_ERROR "CMake >= 2.8.3 required") -endif() -if(CMAKE_VERSION VERSION_LESS "2.8.3") - message(FATAL_ERROR "CMake >= 2.8.3 required") -endif() -cmake_policy(PUSH) -cmake_policy(VERSION 2.8.3...4.1) -#---------------------------------------------------------------- -# Generated CMake target import file. -#---------------------------------------------------------------- - -# Commands may need to know the format version. -set(CMAKE_IMPORT_FILE_VERSION 1) - -# Protect against multiple inclusion, which would fail when already imported targets are added once more. -set(_cmake_targets_defined "") -set(_cmake_targets_not_defined "") -set(_cmake_expected_targets "") -foreach(_cmake_expected_target IN ITEMS superlu::superlu) - list(APPEND _cmake_expected_targets "${_cmake_expected_target}") - if(TARGET "${_cmake_expected_target}") - list(APPEND _cmake_targets_defined "${_cmake_expected_target}") - else() - list(APPEND _cmake_targets_not_defined "${_cmake_expected_target}") - endif() -endforeach() -unset(_cmake_expected_target) -if(_cmake_targets_defined STREQUAL _cmake_expected_targets) - unset(_cmake_targets_defined) - unset(_cmake_targets_not_defined) - unset(_cmake_expected_targets) - unset(CMAKE_IMPORT_FILE_VERSION) - cmake_policy(POP) - return() -endif() -if(NOT _cmake_targets_defined STREQUAL "") - string(REPLACE ";" ", " _cmake_targets_defined_text "${_cmake_targets_defined}") - string(REPLACE ";" ", " _cmake_targets_not_defined_text "${_cmake_targets_not_defined}") - message(FATAL_ERROR "Some (but not all) targets in this export set were already defined.\nTargets Defined: ${_cmake_targets_defined_text}\nTargets not yet defined: ${_cmake_targets_not_defined_text}\n") -endif() -unset(_cmake_targets_defined) -unset(_cmake_targets_not_defined) -unset(_cmake_expected_targets) - - -# Create imported target superlu::superlu -add_library(superlu::superlu STATIC IMPORTED) - -set_target_properties(superlu::superlu PROPERTIES - INTERFACE_INCLUDE_DIRECTORIES "/home/bruno/Git/MYSTRAN/superlu/SRC" - INTERFACE_LINK_LIBRARIES "blas;/home/bruno/Git/MYSTRAN/Binaries/lib/libmetis.a;/home/bruno/Git/MYSTRAN/Binaries/lib/libGKlib.a;m" -) - -# Import target "superlu::superlu" for configuration "Debug" -set_property(TARGET superlu::superlu APPEND PROPERTY IMPORTED_CONFIGURATIONS DEBUG) -set_target_properties(superlu::superlu PROPERTIES - IMPORTED_LINK_INTERFACE_LANGUAGES_DEBUG "C" - IMPORTED_LOCATION_DEBUG "/home/bruno/Git/MYSTRAN/Binaries/lib/libsuperlu.a" - ) - -# Make sure the targets which have been exported in some other -# export set exist. -unset(${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets) -foreach(_target "blas" ) - if(NOT TARGET "${_target}" ) - set(${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets "${${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets} ${_target}") - endif() -endforeach() - -if(DEFINED ${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets) - if(CMAKE_FIND_PACKAGE_NAME) - set( ${CMAKE_FIND_PACKAGE_NAME}_FOUND FALSE) - set( ${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE "The following imported targets are referenced, but are missing: ${${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets}") - else() - message(FATAL_ERROR "The following imported targets are referenced, but are missing: ${${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets}") - endif() -endif() -unset(${CMAKE_FIND_PACKAGE_NAME}_NOT_FOUND_MESSAGE_targets) - -# Commands beyond this point should not need to know the version. -set(CMAKE_IMPORT_FILE_VERSION) -cmake_policy(POP) diff --git a/build/superlu/SRC/superlu_config.h b/build/superlu/SRC/superlu_config.h deleted file mode 100644 index eeb2a1e4..00000000 --- a/build/superlu/SRC/superlu_config.h +++ /dev/null @@ -1,24 +0,0 @@ - -#ifndef SUPERLU_CONFIG_H -#define SUPERLU_CONFIG_H - -/* Enable metis */ -#define HAVE_METIS TRUE - -/* Enable colamd */ -/* #undef HAVE_COLAMD */ - -/* enable 64bit index mode */ -/* #undef XSDK_INDEX_SIZE */ - -/* Integer type for indexing sparse matrix meta structure */ -#if defined(XSDK_INDEX_SIZE) && (XSDK_INDEX_SIZE == 64) -#include -#define _LONGINT 1 -typedef int64_t int_t; -#else -typedef int int_t; /* default */ -#endif - -#endif /* SUPERLU_CONFIG_H */ - diff --git a/build/superlu/superlu.pc b/build/superlu/superlu.pc deleted file mode 100644 index 9a7be44e..00000000 --- a/build/superlu/superlu.pc +++ /dev/null @@ -1,12 +0,0 @@ -prefix=/usr/local -libdir=/usr/local/lib -includedir=/usr/local/include - -Name: Mystran -Description: Direct solution of large, sparse systems of linear equations -Version: 7.0.1 -URL: https://portal.nersc.gov/project/sparse/superlu/ - -Libs: -L${libdir} -lsuperlu -Libs.private: blas -lm -Cflags: -I${includedir} diff --git a/extra_licenses/atlas.txt b/extra_licenses/atlas.txt new file mode 100644 index 00000000..f28045fb --- /dev/null +++ b/extra_licenses/atlas.txt @@ -0,0 +1,26 @@ +Copyright information is provided in the individual files, but all files +are licensed according the 3-clause BSD license (see below). + + 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. The name of the ATLAS group or the names of its contributers may + not be used to endorse or promote products derived from this + software without specific 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 ATLAS GROUP OR ITS 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. diff --git a/extra_licenses/blis.txt b/extra_licenses/blis.txt new file mode 100644 index 00000000..04592206 --- /dev/null +++ b/extra_licenses/blis.txt @@ -0,0 +1,46 @@ +NOTE: Portions of this project's code are copyrighted by + + The University of Texas at Austin + Southern Methodist University + +while other portions are copyrighted by + + Hewlett Packard Enterprise Development LP + Advanced Micro Devices, Inc. + Oracle Corporation + +with some overlap. Please see file-level license headers for file-specific +copyright info. All parties provide their portions of the code under the +3-clause BSD license, found below. + +--- + +Copyright (C) 2012 - 2022, The University of Texas at Austin +Copyright (C) 2018 - 2025, Southern Methodist University +Copyright (C) 2016, Hewlett Packard Enterprise Development LP +Copyright (C) 2018 - 2019, Advanced Micro Devices, Inc. +Copyright (C) 2022, Oracle Corporation + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + - 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. + - Neither the name(s) of the copyright holder(s) 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 COPYRIGHT +HOLDER 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. diff --git a/extra_licenses/mkl.txt b/extra_licenses/mkl.txt new file mode 100644 index 00000000..6d8d48cc --- /dev/null +++ b/extra_licenses/mkl.txt @@ -0,0 +1,69 @@ +Intel Simplified Software License (Version October 2022) + +Use and Redistribution. You may use and redistribute the software, which is +provided in binary form only, (the “Software”), without modification, provided the +following conditions are met: + +* Redistributions must reproduce the above copyright notice and these terms of use +in the Software and in the documentation and/or other materials provided with +the distribution. +* Neither the name of Intel nor the names of its suppliers may be used to endorse +or promote products derived from this Software without specific prior written +permission. +* No reverse engineering, decompilation, or disassembly of the Software is +permitted, nor any modification or alteration of the Software or its operation +at any time, including during execution. + +No other licenses. Except as provided in the preceding section, Intel grants no +licenses or other rights by implication, estoppel or otherwise to, patent, +copyright, trademark, trade name, service mark or other intellectual property +licenses or rights of Intel. + +Third party software. “Third Party Software” means the files (if any) listed in +the “third-party-software.txt” or other similarly-named text file that may be +included with the Software. Third Party Software, even if included with the +distribution of the Software, may be governed by separate license terms, including +without limitation, third party license terms, open source software notices and +terms, and/or other Intel software license terms. These separate license terms +solely govern Your use of the Third Party Software. + +DISCLAIMER. THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT ARE +DISCLAIMED. THIS SOFTWARE IS NOT INTENDED FOR USE IN SYSTEMS OR APPLICATIONS WHERE +FAILURE OF THE SOFTWARE MAY CAUSE PERSONAL INJURY OR DEATH AND YOU AGREE THAT YOU +ARE FULLY RESPONSIBLE FOR ANY CLAIMS, COSTS, DAMAGES, EXPENSES, AND ATTORNEYS’ +FEES ARISING OUT OF ANY SUCH USE, EVEN IF ANY CLAIM ALLEGES THAT INTEL WAS +NEGLIGENT REGARDING THE DESIGN OR MANUFACTURE OF THE SOFTWARE. + +LIMITATION OF LIABILITY. IN NO EVENT WILL INTEL 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. + +No support. Intel may make changes to the Software, at any time without notice, +and is not obligated to support, update or provide training for the Software. +Termination. Your right to use the Software is terminated in the event of your +breach of this license. + +Feedback. Should you provide Intel with comments, modifications, corrections, +enhancements or other input (“Feedback”) related to the Software, Intel will be +free to use, disclose, reproduce, license or otherwise distribute or exploit the +Feedback in its sole discretion without any obligations or restrictions of any +kind, including without limitation, intellectual property rights or licensing +obligations. + +Compliance with laws. You agree to comply with all relevant laws and regulations +governing your use, transfer, import or export (or prohibition thereof) of the +Software. + +Governing law. All disputes will be governed by the laws of the United States of +America and the State of Delaware without reference to conflict of law principles +and subject to the exclusive jurisdiction of the state or federal courts sitting +in the State of Delaware, and each party agrees that it submits to the personal +jurisdiction and venue of those courts and waives any objections. THE UNITED +NATIONS CONVENTION ON CONTRACTS FOR THE INTERNATIONAL SALE OF GOODS (1980) IS +SPECIFICALLY EXCLUDED AND WILL NOT APPLY TO THE SOFTWARE. diff --git a/extra_licenses/blas-lapack.txt b/extra_licenses/netlib-blas-lapack.txt similarity index 100% rename from extra_licenses/blas-lapack.txt rename to extra_licenses/netlib-blas-lapack.txt diff --git a/extra_licenses/openblas.txt b/extra_licenses/openblas.txt new file mode 100644 index 00000000..284f06cc --- /dev/null +++ b/extra_licenses/openblas.txt @@ -0,0 +1,29 @@ +Copyright (c) 2011-2014, 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 COPYRIGHT OWNER 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. diff --git a/metis/GKlib b/submodules/GKlib similarity index 100% rename from metis/GKlib rename to submodules/GKlib diff --git a/metis/gklib_patches/CMakeLists.txt b/submodules/gklib_patches/CMakeLists.txt similarity index 100% rename from metis/gklib_patches/CMakeLists.txt rename to submodules/gklib_patches/CMakeLists.txt diff --git a/Source/lapack b/submodules/lapack similarity index 100% rename from Source/lapack rename to submodules/lapack diff --git a/submodules/lapack_patches/CMAKE/PreventInSourceBuilds.cmake b/submodules/lapack_patches/CMAKE/PreventInSourceBuilds.cmake new file mode 100644 index 00000000..c176d420 --- /dev/null +++ b/submodules/lapack_patches/CMAKE/PreventInSourceBuilds.cmake @@ -0,0 +1,12 @@ +# MYSTRAN patch: the upstream Reference-LAPACK CMake refuses to be built +# when CMAKE_BINARY_DIR == CMAKE_SOURCE_DIR. MYSTRAN's own configuration +# is an in-source build by design (see CMakeLists.txt), so the embedded +# LAPACK sub-build fails that check even though its actual binary dir +# (under ${PROJECT_BINARY_DIR}/lapack) is disjoint from its source tree. +# +# This stub replaces the upstream guard with a no-op so the embedded +# build can proceed. +function(AssureOutOfSourceBuilds) +endfunction() + +AssureOutOfSourceBuilds() diff --git a/metis/METIS b/submodules/metis similarity index 100% rename from metis/METIS rename to submodules/metis diff --git a/metis/metis_patches/CMakeLists.txt b/submodules/metis_patches/CMakeLists.txt similarity index 100% rename from metis/metis_patches/CMakeLists.txt rename to submodules/metis_patches/CMakeLists.txt diff --git a/superlu b/submodules/superlu similarity index 100% rename from superlu rename to submodules/superlu diff --git a/superlu_mt b/submodules/superlu_mt similarity index 100% rename from superlu_mt rename to submodules/superlu_mt diff --git a/superlu_mt_patches/CMakeLists.txt b/submodules/superlu_mt_patches/CMakeLists.txt similarity index 91% rename from superlu_mt_patches/CMakeLists.txt rename to submodules/superlu_mt_patches/CMakeLists.txt index 88f84ce8..cf37ce83 100644 --- a/superlu_mt_patches/CMakeLists.txt +++ b/submodules/superlu_mt_patches/CMakeLists.txt @@ -84,15 +84,13 @@ if(BLAS_FOUND) string(REPLACE ";" " " BLAS_LIB_STR "${BLAS_LIB}") set(BLAS_LIB_EXPORT ${BLAS_LIB_STR}) else() - message("-- Did not find or specify BLAS so configure to build internal CBLAS ...") - add_subdirectory(CBLAS) - set(BLAS_LIB blas) - - if(BUILD_SHARED_LIBS) # export to be referenced by downstream makefile - set(BLAS_LIB_EXPORT ${CMAKE_INSTALL_PREFIX}/CBLAS/libblas.so) - else() - set(BLAS_LIB_EXPORT ${CMAKE_INSTALL_PREFIX}/CBLAS/libblas.a) - endif() + # MYSTRAN never lets SuperLU_MT build its own bundled CBLAS: BLAS comes + # exclusively from either the system or the Reference-LAPACK submodule, + # both forwarded via TPL_BLAS_LIBRARIES from the top-level CMakeLists. + message(FATAL_ERROR + "SuperLU_MT could not find a BLAS provider. The MYSTRAN build is " + "expected to always pass TPL_BLAS_LIBRARIES; building SuperLU_MT's " + "internal CBLAS is disabled.") endif() # -- METIS diff --git a/superlu_mt_patches/SRC/CMakeLists.txt b/submodules/superlu_mt_patches/SRC/CMakeLists.txt similarity index 100% rename from superlu_mt_patches/SRC/CMakeLists.txt rename to submodules/superlu_mt_patches/SRC/CMakeLists.txt diff --git a/superlu_mt_patches/SRC/c_fortran_pdgssv.c b/submodules/superlu_mt_patches/SRC/c_fortran_pdgssv.c similarity index 100% rename from superlu_mt_patches/SRC/c_fortran_pdgssv.c rename to submodules/superlu_mt_patches/SRC/c_fortran_pdgssv.c diff --git a/superlu_mt_patches/SRC/get_perm_c.c b/submodules/superlu_mt_patches/SRC/get_perm_c.c similarity index 100% rename from superlu_mt_patches/SRC/get_perm_c.c rename to submodules/superlu_mt_patches/SRC/get_perm_c.c diff --git a/superlu_mt_patches/SRC/pmemory.c b/submodules/superlu_mt_patches/SRC/pmemory.c similarity index 100% rename from superlu_mt_patches/SRC/pmemory.c rename to submodules/superlu_mt_patches/SRC/pmemory.c diff --git a/superlu_mt_patches/SRC/sp_ienv.c b/submodules/superlu_mt_patches/SRC/sp_ienv.c similarity index 100% rename from superlu_mt_patches/SRC/sp_ienv.c rename to submodules/superlu_mt_patches/SRC/sp_ienv.c diff --git a/superlu_patches/CMakeLists.txt b/submodules/superlu_patches/CMakeLists.txt similarity index 95% rename from superlu_patches/CMakeLists.txt rename to submodules/superlu_patches/CMakeLists.txt index 5db5e79e..55e52899 100644 --- a/superlu_patches/CMakeLists.txt +++ b/submodules/superlu_patches/CMakeLists.txt @@ -162,15 +162,13 @@ if(BLAS_FOUND) string(REPLACE ";" " " BLAS_LIB_STR "${BLAS_LIB}") set(BLAS_LIB_EXPORT ${BLAS_LIB_STR}) else() - message("-- Did not find or specify BLAS so configure to build internal CBLAS ...") - add_subdirectory(CBLAS) - set(BLAS_LIB blas) - - if(BUILD_SHARED_LIBS) # export to be referenced by downstream makefile - set(BLAS_LIB_EXPORT ${CMAKE_INSTALL_PREFIX}/CBLAS/libblas.so) - else() - set(BLAS_LIB_EXPORT ${CMAKE_INSTALL_PREFIX}/CBLAS/libblas.a) - endif() + # MYSTRAN never lets SuperLU build its own bundled CBLAS: BLAS comes + # exclusively from either the system or the Reference-LAPACK submodule, + # both forwarded via TPL_BLAS_LIBRARIES from the top-level CMakeLists. + message(FATAL_ERROR + "SuperLU could not find a BLAS provider. The MYSTRAN build is " + "expected to always pass TPL_BLAS_LIBRARIES; building SuperLU's " + "internal CBLAS is disabled.") endif() # --------------------- METIS --------------------- diff --git a/superlu_patches/FORTRAN/c_fortran_dgssv.c b/submodules/superlu_patches/FORTRAN/c_fortran_dgssv.c similarity index 100% rename from superlu_patches/FORTRAN/c_fortran_dgssv.c rename to submodules/superlu_patches/FORTRAN/c_fortran_dgssv.c diff --git a/superlu_mt_patches/CBLAS/CMakeLists.txt b/superlu_mt_patches/CBLAS/CMakeLists.txt deleted file mode 100644 index 6495835b..00000000 --- a/superlu_mt_patches/CBLAS/CMakeLists.txt +++ /dev/null @@ -1,98 +0,0 @@ -set(headers - f2c.h - slu_Cnames.h -) - -# set(sources input_error.c) -set(sources "") - -# if (enable_single) -list(APPEND sources - isamax.c - sasum.c - saxpy.c - scopy.c - sdot.c - snrm2.c - srot.c - sscal.c - sgemv.c - ssymv.c - strsv.c - sger.c - ssyr2.c -) - -# endif() - -# if (enable_double) -list(APPEND sources - idamax.c - dasum.c - daxpy.c - dcopy.c - ddot.c - dnrm2.c - drot.c - dscal.c - dgemv.c - dsymv.c - dtrsv.c - dger.c - dsyr2.c -) - -# endif() - -# if (enable_complex) -list(APPEND sources - icamax.c - scasum.c - caxpy.c - ccopy.c - scnrm2.c - cscal.c - cdotc.c - cgemv.c - chemv.c - ctrsv.c - cgerc.c - cher2.c -) - -# endif() - -# if (enable_complex16) -list(APPEND sources - izamax.c - dzasum.c - zaxpy.c - zcopy.c - dznrm2.c - zscal.c - dcabs1.c - zdotc.c - zgemv.c - zhemv.c - ztrsv.c - zgerc.c - zher2.c -) - -# endif() -add_library(blas ${sources}) - -include(GNUInstallDirs) -install(TARGETS blas - EXPORT blasTargets - LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} - ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} - INCLUDES DESTINATION "${CMAKE_INSTALL_INCLUDEDIR}" -) - -install(EXPORT blasTargets - DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/superlu" -) -export(EXPORT blasTargets - FILE "${CMAKE_CURRENT_BINARY_DIR}/blasTargets.cmake" -) From 47d72b6cf88cc80e25c650c09d3bb1522334bb71 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Wed, 27 May 2026 23:37:20 -0300 Subject: [PATCH 04/11] set openblas threads to 1 --- CMakeLists.txt | 7 +++++++ Source/MAIN/MYSTRAN.f90 | 7 +++++++ Source/USE_IFs/MYSTRAN_USE_IFs.f90 | 1 + 3 files changed, 15 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 7b47550c..0fcf7a08 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -680,6 +680,13 @@ else() list(APPEND _MYSTRAN_STATIC_DEFS "_STATIC_${_SYS_BLAS_TAG}") list(APPEND _MYSTRAN_STATIC_NAMES "${_SYS_BLAS_LIBNAME}") + # Provider-specific runtime hooks (e.g. thread-count limiter in + # Source/MAIN/SET_BLAS_THREADS.F03). Defined here so it's only + # active when the corresponding BLAS is actually linked. + if(_SYS_BLAS_TAG STREQUAL "OPENBLAS") + target_compile_definitions(mystran PRIVATE MYSTRAN_USE_OPENBLAS) + endif() + if(NOT EXISTS "${PROJECT_SOURCE_DIR}/${_SYS_BLAS_LICENSE_PATH}") message(WARNING "System BLAS/LAPACK detected as ${_SYS_BLAS_LIBNAME}, but the " diff --git a/Source/MAIN/MYSTRAN.f90 b/Source/MAIN/MYSTRAN.f90 index 2a5ba474..3d8bb14b 100644 --- a/Source/MAIN/MYSTRAN.f90 +++ b/Source/MAIN/MYSTRAN.f90 @@ -134,6 +134,13 @@ PROGRAM MYSTRAN OPEN(SC1) +! Cap threads used by the linked BLAS provider (e.g. OpenBLAS). MYSTRAN +! drives BLAS from its own serial loops, so per-call thread fan-out is +! pure overhead. This is a no-op unless a recognized threaded BLAS +! provider was detected at configure time. + + CALL SET_BLAS_THREADS ( 1_LONG ) + ! Set time initializing parameters CALL TIME_INIT diff --git a/Source/USE_IFs/MYSTRAN_USE_IFs.f90 b/Source/USE_IFs/MYSTRAN_USE_IFs.f90 index 329abc37..ff33bab2 100644 --- a/Source/USE_IFs/MYSTRAN_USE_IFs.f90 +++ b/Source/USE_IFs/MYSTRAN_USE_IFs.f90 @@ -58,5 +58,6 @@ MODULE MYSTRAN_USE_IFs USE VECTOR_NORM_Interface USE PRINT_BUILD_INFO_Interface USE READ_CL_Interface + USE SET_BLAS_THREADS_Interface END MODULE MYSTRAN_USE_IFs From 0fd77922389deeb3fa4826655b4fe437857c38c0 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Wed, 27 May 2026 23:41:21 -0300 Subject: [PATCH 05/11] build instructions updated --- BUILD.md | 51 ++++++++++++++++++++++++++++----------------------- 1 file changed, 28 insertions(+), 23 deletions(-) diff --git a/BUILD.md b/BUILD.md index 05301c77..83570d90 100644 --- a/BUILD.md +++ b/BUILD.md @@ -20,9 +20,10 @@ Open the MSYS2 terminal and run the following commands: 1. **`pacman -Syu`** This updates repository information and installed packages, and might require you close and reopen MSYS2 terminals. - 1. **`pacman -S mingw-w64-x86_64-gcc-fortran mingw-w64-x86_64-cmake mingw-w64-x86_64-make git`** + 1. **`pacman -S mingw-w64-x86_64-gcc-fortran mingw-w64-x86_64-cmake mingw-w64-x86_64-ninja mingw-w64-x86_64-openblas git`** This installs the required compilers (the GNU C and Fortran compilers), CMake -itself, and `git`. +itself, the Ninja build tool, OpenBLAS (the recommended BLAS/LAPACK +provider), and `git`. 1. **`export PATH="/mingw64/bin:$PATH"`** This makes the MinGW toolchain programs (such as `make` and the compilers) visible so CMake can find them more easily. Note that this command's effects @@ -35,9 +36,11 @@ Follow your distribution's steps to install the following programs/libraries: - **`gcc`** - **`g++`** - **`gfortran`** - - **`make`** + - **`ninja`** (recommended; package is usually `ninja-build`) - **`cmake`** - **`git`** + - **`openblas`** (recommended BLAS/LAPACK provider; package is usually + `libopenblas-dev` on Debian/Ubuntu or `openblas-devel` on Fedora/RHEL) All of those are fairly common, so get in touch in the MYSTRAN Forums or MYSTRAN Discord if you have trouble installing any of them. Also, note that @@ -63,7 +66,7 @@ Now that you've got into a modern version of Ubuntu ``` sudo apt update sudo apt upgrade -apt install gcc g++ gfortran make cmake git +sudo apt install gcc g++ gfortran ninja-build cmake git libopenblas-dev ``` --- @@ -82,10 +85,11 @@ straightforward. **`git clone https://github.com/MYSTRANsolver/MYSTRAN.git`**. 4. Move the terminal to the MYSTRAN folder. If you've just run `git clone`, just do a **`cd MYSTRAN`**. - 5. Generate the build scripts by running **`cmake -G "MinGW Makefiles" .`**. - 6. Compile with **`mingw32-make`**. If you have an N-core processor, running - **`mingw32-make -Oline -jN`** will probably be much faster. A good choice of N is - printed in the previous step, right before the end. The `-Oline` argument prevents garbled output when `N` > 1. + 5. Generate the build scripts by running **`cmake -G Ninja .`**. + 6. Compile with **`cmake --build .`**. If you have an N-core processor, + running **`cmake --build . -jN`** will probably be much faster (Ninja already + parallelizes by default, but `-jN` lets you cap it). You can find the number + of cores/threads with the `nproc` command. 7. The executable will reside at **`Binaries/mystran.exe`**. ### Steps for Linux (any) @@ -96,11 +100,11 @@ straightforward. **`git clone https://github.com/MYSTRANsolver/MYSTRAN.git`**. 3. Move the terminal to the MYSTRAN folder. If you've just run `git clone`, just do a **`cd MYSTRAN`**. - 1. Generate the build scripts by running **`cmake .`**. - 2. Compile with **`make`**. If you have an N-core processor, running - **`make -jN`** will probably me much faster. A good choice of N is printed in - the previous step, right before the end. You can also find the number of - cores/threads with the `nproc` command (not all distros ship it + 1. Generate the build scripts by running **`cmake -G Ninja .`**. + 2. Compile with **`cmake --build .`**. If you have an N-core processor, + running **`cmake --build . -jN`** will probably be much faster (Ninja already + parallelizes by default, but `-jN` lets you cap it). You can find the number + of cores/threads with the `nproc` command (not all distros ship it out-of-the-box though). 1. The executable will reside at **`Binaries/mystran`**. @@ -124,11 +128,11 @@ Run a **`pacman -Syyu`** (note the two 'y's) and try again. --- -### "CMake is complaining about not being able to find the toolchain or the Fortran compiler or the "make" command!" +### "CMake is complaining about not being able to find the toolchain or the Fortran compiler or the build tool!" -Try running the commands `make`/`mingw32-make`, `gcc`, and `gfortran`. If any -of these comes up as a "command not found", make sure they've been installed. -If you're **sure** they are, they might not be in the PATH. +Try running the commands `ninja`, `gcc`, and `gfortran`. If any of these comes +up as a "command not found", make sure they've been installed. If you're +**sure** they are, they might not be in the PATH. Windows users, have a look at step #3 of the setup. Linux users, check out your distro documentation, because whatever's happening should not be happening at @@ -157,8 +161,8 @@ distro ships CMake 3.17 or older. Bad luck there. Here's what you can do: ### "I'm getting random SuperLU build errors!" SuperLU is included as a submodule. A recent update to the submodule might -require a clean build. Run `make clean` and delete the `superlu` subdirectory -and run the appropriate `cmake` command again. +require a clean build. Run `cmake --build . --target clean` and delete the +`superlu` subdirectory and run the appropriate `cmake` command again. --- @@ -207,11 +211,12 @@ fine. ### "The terminal output is garbled during compilation!" -Multiple threads are printing to standard output simultaneously. That issue can -sometimes happen as a result of running `make` instead of `mingw32-make` on -Windows, but it can affect both. It's annoying, but harmless. +Multiple threads are printing to standard output simultaneously. Ninja +serializes per-job output by default, so this should not happen with the +recommended generator. If you're using the legacy `make`/`mingw32-make` +generators and see garbled output, switch to Ninja (`cmake -G Ninja .`). -However, if you *really* need compiler output to be readable, ensure `make` +If you *really* need to keep using `make` and want readable output, ensure it only runs with one thread by passing the option `-j1`. This will make compilation slower, but at least you'll be able to read the output. From 2502fa1bc7c236266be8f9fcb7c389cc7bc87bf3 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Thu, 28 May 2026 00:25:23 -0300 Subject: [PATCH 06/11] forgot to add the SET_BLAS_THREADS files --- .../Interfaces/SET_BLAS_THREADS_Interface.f90 | 42 +++++++++++ Source/MAIN/SET_BLAS_THREADS.F03 | 73 +++++++++++++++++++ 2 files changed, 115 insertions(+) create mode 100644 Source/Interfaces/SET_BLAS_THREADS_Interface.f90 create mode 100644 Source/MAIN/SET_BLAS_THREADS.F03 diff --git a/Source/Interfaces/SET_BLAS_THREADS_Interface.f90 b/Source/Interfaces/SET_BLAS_THREADS_Interface.f90 new file mode 100644 index 00000000..75d6c93f --- /dev/null +++ b/Source/Interfaces/SET_BLAS_THREADS_Interface.f90 @@ -0,0 +1,42 @@ +! Begin MIT license text. +! _______________________________________________________________________________________________________ + +! Copyright 2022 Dr William R Case, Jr (mystransolver@gmail.com) + +! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and +! associated documentation files (the "Software"), to deal in the Software without restriction, including +! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to +! the following conditions: + +! The above copyright notice and this permission notice shall be included in all copies or substantial +! portions of the Software and documentation. + +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. +! _______________________________________________________________________________________________________ + +! End MIT license text. + + MODULE SET_BLAS_THREADS_Interface + + INTERFACE + + SUBROUTINE SET_BLAS_THREADS ( NTHREADS ) + + USE PENTIUM_II_KIND, ONLY : LONG + + IMPLICIT NONE + + INTEGER(LONG), INTENT(IN) :: NTHREADS + + END SUBROUTINE SET_BLAS_THREADS + + END INTERFACE + + END MODULE SET_BLAS_THREADS_Interface diff --git a/Source/MAIN/SET_BLAS_THREADS.F03 b/Source/MAIN/SET_BLAS_THREADS.F03 new file mode 100644 index 00000000..64262f78 --- /dev/null +++ b/Source/MAIN/SET_BLAS_THREADS.F03 @@ -0,0 +1,73 @@ +! ################################################################################################################################## +! Begin MIT license text. +! _______________________________________________________________________________________________________ + +! Copyright 2022 Dr William R Case, Jr (mystransolver@gmail.com) + +! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and +! associated documentation files (the "Software"), to deal in the Software without restriction, including +! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to +! the following conditions: + +! The above copyright notice and this permission notice shall be included in all copies or substantial +! portions of the Software and documentation. + +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. +! _______________________________________________________________________________________________________ + +! End MIT license text. + +! ################################################################################################################################## +! Cap the number of threads used by the linked BLAS/LAPACK provider. +! +! MYSTRAN is single-threaded at the Fortran level and calls BLAS/LAPACK +! routines from inside its own loops. When linked against a threaded +! BLAS such as OpenBLAS, the BLAS runtime will, by default, spin up one +! worker thread per logical core for every BLAS call. For the typical +! MYSTRAN workload (lots of small/medium GEMM/GEMV/SYMM calls) this +! produces severe thread-launch overhead and actually slows the solver +! down compared to a single-threaded BLAS. +! +! This routine is the one place where we tell the BLAS provider how +! many threads to use. The implementation is selected at compile time +! via preprocessor macros set by CMakeLists.txt: +! +! MYSTRAN_USE_OPENBLAS - call openblas_set_num_threads(int) +! +! If no recognized provider macro is defined (e.g. embedded +! Reference-LAPACK, system Reference-BLAS, MKL, BLIS, ...) the routine +! is a no-op. +! ################################################################################################################################## + SUBROUTINE SET_BLAS_THREADS ( NTHREADS ) + + USE PENTIUM_II_KIND, ONLY : LONG + USE ISO_C_BINDING, ONLY : C_INT + + IMPLICIT NONE + + INTEGER(LONG), INTENT(IN) :: NTHREADS ! Desired number of BLAS worker threads + +#ifdef MYSTRAN_USE_OPENBLAS + INTERFACE + SUBROUTINE OPENBLAS_SET_NUM_THREADS_C ( N ) BIND(C, NAME="openblas_set_num_threads") + IMPORT :: C_INT + INTEGER(C_INT), VALUE :: N + END SUBROUTINE OPENBLAS_SET_NUM_THREADS_C + END INTERFACE + + CALL OPENBLAS_SET_NUM_THREADS_C ( INT(NTHREADS, C_INT) ) +#else + INTEGER(LONG) :: IGNORED + IGNORED = NTHREADS +#endif + + RETURN + + END SUBROUTINE SET_BLAS_THREADS From a1693930820fb6cd1ff4ffb39db536a08e39a3d5 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Thu, 28 May 2026 00:40:56 -0300 Subject: [PATCH 07/11] got rid of f2c --- CMakeLists.txt | 83 ++------------------------------------------------ 1 file changed, 3 insertions(+), 80 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 0fcf7a08..b27ec89b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -427,78 +427,6 @@ else() set(SLU_DRIVER "${SUPERLU_DIR}/FORTRAN/c_fortran_dgssv.c") endif() -# f2c stuff -set(F2C_DIR "${PROJECT_SOURCE_DIR}/f2c") -set(F2C_INCLUDE_DIR "${F2C_DIR}/include") -set(F2C_FN "${F2C_DIR}/libf2c.zip") -set(F2C_URL "https://www.netlib.org/f2c/libf2c.zip") - -# download f2c -if(NOT EXISTS ${F2C_DIR}) - message(STATUS "Downloading libf2c source from ${F2C_URL}...") - make_directory("${F2C_DIR}") - file(DOWNLOAD ${F2C_URL} ${F2C_FN} TIMEOUT 60 STATUS DOWNLOAD_STATUS) - - # Check if download was successful. - list(GET DOWNLOAD_STATUS 0 STATUS_CODE) - list(GET DOWNLOAD_STATUS 1 ERROR_MESSAGE) - - if(${STATUS_CODE} EQUAL 0) - message(STATUS "Done downloading libf2c.") - else() - # Exit CMake if the download failed, printing the error message. - file(REMOVE_RECURSE ${F2C_DIR}) - message(FATAL_ERROR "Error downloading libf2c: ${ERROR_MESSAGE}") - endif() -endif() - -# extract libf2c source -file(ARCHIVE_EXTRACT INPUT ${F2C_FN} DESTINATION ${F2C_DIR}) - -# prepare libf2c header files -file(GLOB_RECURSE F2C_PREHEADERS "${F2C_DIR}/*.h0") - -foreach(H0 ${F2C_PREHEADERS}) - string(REGEX REPLACE "[.]h0$" ".h" H0_R ${H0}) - file(RENAME "${H0}" "${H0_R}") - file(COPY "${H0_R}" DESTINATION "${F2C_INCLUDE_DIR}") -endforeach() - -# get a load of this: f2c generates its own "arith.h" on the fly -# so we gotta compile arithchk and run it -set(F2C_ARITHCHK_SRC "${F2C_DIR}/arithchk.c") -set(F2C_ARITHCHK_BIN "${F2C_DIR}/arithchk") - -if(WIN32) - set(F2C_ARITHCHK_BIN "${F2C_ARITHCHK_BIN}.exe") -endif() - -set(F2C_ARITH_H "${F2C_INCLUDE_DIR}/arith.h") -set_source_files_properties( - ${F2C_ARITHCHK_SRC} PROPERTIES COMPILE_FLAGS "-DNO_LONG_LONG -DNO_FPINIT" -) -add_executable(arithchk ${F2C_ARITHCHK_SRC}) -target_link_libraries(arithchk m) -set_target_properties( - arithchk PROPERTIES RUNTIME_OUTPUT_DIRECTORY ${F2C_DIR} -) -add_custom_command( - OUTPUT ${F2C_ARITH_H} - COMMAND ${F2C_ARITHCHK_BIN} > ${F2C_ARITH_H} - DEPENDS ${F2C_ARITHCHK_BIN} -) - -# add libf2c to the compilation procedures -include_directories(${F2C_INCLUDE_DIR}) -file(GLOB_RECURSE F2C_CFILES "${F2C_DIR}/*.c") -add_definitions(-DINTEGER_STAR_8) -add_library(f2c ${F2C_CFILES} ${F2C_ARITH_H}) - -# add some extra win32 flags for libf2c -if(WIN32) - add_definitions(-DUSE_CLOCK -DMSDOS) -endif() - # set some extra vars for MSYS builds to make the binary portable if(WIN32) set(CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} -static -static-libgcc -static-libstdc++") @@ -530,9 +458,9 @@ add_executable( if(USE_SUPERLU_MT) if(PLAT STREQUAL "_PTHREAD") message(WARNING "We recommend using OpenMP, not pthread!") - target_link_libraries(mystran superlu_mt_PTHREAD f2c) + target_link_libraries(mystran superlu_mt_PTHREAD) elseif(PLAT STREQUAL "_OPENMP") - target_link_libraries(mystran superlu_mt_OPENMP f2c) + target_link_libraries(mystran superlu_mt_OPENMP) endif() target_compile_definitions(mystran PRIVATE USE_SUPERLU_MT) @@ -541,7 +469,7 @@ if(USE_SUPERLU_MT) target_compile_definitions(mystran PRIVATE HAVE_METIS) endif() else() - target_link_libraries(mystran superlu f2c) + target_link_libraries(mystran superlu) endif() # Link LAPACK first, then BLAS: LAPACK depends on BLAS so the linker @@ -569,10 +497,6 @@ endif() set(_MYSTRAN_STATIC_DEFS "") set(_MYSTRAN_STATIC_NAMES "") -# f2c is always built and linked as a static archive -list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_F2C) -list(APPEND _MYSTRAN_STATIC_NAMES libf2c.a) - if(USE_SUPERLU_MT) list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_SUPERLU_MT) @@ -730,7 +654,6 @@ list(APPEND _MYSTRAN_STATIC_DEFS _STATIC_ARPACK) # Add new entries here whenever a new statically-linked library is added. # ----------------------------------------------------------------------- set(_MYSTRAN_LICENSE_MAP - "F2C:f2c/Notice:libf2c:Fortran-to-C runtime support library" "SUPERLU:submodules/superlu/License.txt:SuperLU:sparse solver" "SUPERLU_MT:submodules/superlu_mt/License.txt:SuperLU_MT:multi-threaded sparse solver" "METIS:submodules/metis/LICENSE:METIS:graph partitioner for SuperLU" From bdbfa2ddfd10a8cb66e9b966df519fdfb8537f47 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Thu, 28 May 2026 03:50:16 -0300 Subject: [PATCH 08/11] someone forgot ignore=all teehee --- .gitmodules | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitmodules b/.gitmodules index a75e30cd..39836051 100644 --- a/.gitmodules +++ b/.gitmodules @@ -26,3 +26,4 @@ [submodule "Source/lapack"] path = submodules/lapack url = https://github.com/Reference-LAPACK/lapack.git + ignore = all From 9c7e8049a2fbe29c9f13350f1ae9a8ea2ff6a854 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Thu, 28 May 2026 03:58:54 -0300 Subject: [PATCH 09/11] moved a patch --- {superlu_patches => submodules/superlu_patches}/SRC/dmemory.c | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {superlu_patches => submodules/superlu_patches}/SRC/dmemory.c (100%) diff --git a/superlu_patches/SRC/dmemory.c b/submodules/superlu_patches/SRC/dmemory.c similarity index 100% rename from superlu_patches/SRC/dmemory.c rename to submodules/superlu_patches/SRC/dmemory.c From 787c5eec30c6535055db899593e756e17617c71e Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Thu, 28 May 2026 04:17:23 -0300 Subject: [PATCH 10/11] don't mind me just updating the gitmodules --- .gitmodules | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitmodules b/.gitmodules index 39836051..8fbb8438 100644 --- a/.gitmodules +++ b/.gitmodules @@ -27,3 +27,5 @@ path = submodules/lapack url = https://github.com/Reference-LAPACK/lapack.git ignore = all + update = checkout + branch = master From 0aeab803ce908af5a3e06bf98d9e88ceef938367 Mon Sep 17 00:00:00 2001 From: Bruno Borges Paschoalinoto Date: Thu, 28 May 2026 04:33:19 -0300 Subject: [PATCH 11/11] fixed arpack mods breaking buckling decks. thanks victor! --- Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f | 37 +++++++++++----------- 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f b/Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f index 6a88ed3e..666f1f17 100644 --- a/Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f +++ b/Source/Modules/ARPACK/ARPACK_LANCZOS_EIG.f @@ -572,9 +572,9 @@ subroutine dsband( rvec, howmny, select, d, z, ldz, sigma, c %-----------------------------% c !:! REAL(DOUBLE) -!:! & ddot, dnrm2, dlapy2 -!:! external ddot, dcopy, dgbmv, dgbtrf, -!:! & dgbtrs, dnrm2, dlapy2, dlacpy + REAL(DOUBLE) + & ddot, dnrm2, dlapy2 + external ddot, dnrm2, dlapy2 c c %-----------------------% c | Executable Statements | @@ -2301,8 +2301,9 @@ subroutine dseupd (rvec , howmny, select, d , c %--------------------% c !:! REAL(DOUBLE) -!:! & dnrm2 -!:! external dnrm2 + REAL(DOUBLE) + & dnrm2 + external dnrm2 REAL(DOUBLE) & dlamch @@ -3169,9 +3170,9 @@ subroutine dsaup2 c | External Functions | c %--------------------% c -!:! REAL(DOUBLE) -!:! & ddot, dnrm2 -!:! external ddot, dnrm2 + REAL(DOUBLE) + & ddot, dnrm2 + external ddot, dnrm2 REAL(DOUBLE) dlamch external dlamch @@ -4824,9 +4825,9 @@ subroutine dgetv0 c | External Functions | c %--------------------% c -!:! REAL(DOUBLE) -!:! & ddot, dnrm2 -!:! external ddot, dnrm2 + REAL(DOUBLE) + & ddot, dnrm2 + external ddot, dnrm2 c c %---------------------% c | Intrinsic Functions | @@ -5359,9 +5360,9 @@ subroutine dsaitr REAL(DOUBLE) dlamch external dlamch -!:! REAL(DOUBLE) -!:! & ddot, dnrm2 -!:! external ddot, dnrm2 + REAL(DOUBLE) + & ddot, dnrm2 + external ddot, dnrm2 c c %-----------------% c | Data statements | @@ -6977,10 +6978,10 @@ subroutine dstqrb ( n, d, e, z, work, info ) & s, safmax, safmin, ssfmax, ssfmin, tst c .. c .. external functions .. -!:! logical lsame -!:! REAL(DOUBLE) -!:! & dlapy2 -!:! external lsame, dlapy2 + logical lsame + REAL(DOUBLE) + & dlapy2 + external lsame, dlapy2 REAL(DOUBLE) dlamch, dlanst external dlamch, dlanst