fortran-lang-stdlib-0ede301/ 0000775 0001750 0001750 00000000000 15135654166 016166 5 ustar alastair alastair fortran-lang-stdlib-0ede301/API-doc-FORD-file.md 0000664 0001750 0001750 00000010637 15135654166 021340 0 ustar alastair alastair ---
project: Fortran-lang/stdlib
summary: A community driven standard library for (modern) Fortran
src_dir: src
include: src
include
exclude_dir: src/tests
output_dir: API-doc
page_dir: doc
media_dir: doc/media
exclude: src/stdlib_linalg_lapack.fypp
src/stdlib_linalg_lapack_aux.fypp
src/stdlib_linalg_lapack_c.fypp
src/stdlib_linalg_lapack_d.fypp
src/stdlib_linalg_lapack_q.fypp
src/stdlib_linalg_lapack_s.fypp
src/stdlib_linalg_lapack_w.fypp
src/stdlib_linalg_lapack_z.fypp
fpp_extensions: fypp
preprocess: true
macro: MAXRANK=3
PROJECT_VERSION_MAJOR=0
PROJECT_VERSION_MINOR=0
PROJECT_VERSION_PATCH=0
preprocessor: fypp
display: public
protected
source: true
proc_internals: true
md_extensions: markdown.extensions.toc
graph: true
graph_maxnodes: 250
graph_maxdepth: 5
coloured_edges: true
sort: permission-alpha
extra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html
iso_c_binding:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fC_005fBINDING.html#ISO_005fC_005fBINDING
print_creation_date: true
creation_date: %Y-%m-%d %H:%M %z
project_github: https://github.com/fortran-lang/stdlib
project_download: https://github.com/fortran-lang/stdlib/archive/HEAD.zip
project_website: https://stdlib.fortran-lang.org
favicon: doc/media/favicon.ico
license: by-sa
author: fortran-lang/stdlib contributors
author_pic: https://fortran-lang.org/en/_static/fortran-logo-256x256.png
email: fortran-lang@groups.io
github: https://github.com/fortran-lang
twitter: https://twitter.com/fortranlang
website: https://fortran-lang.org
dbg: true
---
[TOC]
@warning This API documentation for the Fortran-lang/stdlib is a work in progress
@note
Use the navigation bar at the top of the screen to browse modules, procedures, source files, etc.
The listings near the bottom of the page are incomplete.
Fortran stdlib API Documentation
================================
This is the main API documentation landing page generated by [FORD].
The documentation for comment markup in source code, running [FORD] and the [FORD project file] are all maintained on the [FORD wiki].
[FORD]: https://github.com/Fortran-FOSS-Programmers/ford#readme
[FORD wiki]: https://github.com/Fortran-FOSS-Programmers/ford/wiki
[FORD project file]: https://github.com/fortran-lang/stdlib/blob/HEAD/API-doc-FORD-file.md
Goals and Motivation
====================
The Fortran Standard, as published by the ISO (https://wg5-fortran.org/), does
not have a Standard Library. The goal of this project is to provide a community
driven and agreed upon *de facto* "standard" library for Fortran, called a
Fortran Standard Library (`stdlib`). We have a rigorous process how `stdlib` is
developed as documented in our [Workflow](page/contributing/Workflow.html). `stdlib` is both a
specification and a reference implementation. We are cooperating with the
Fortran Standards Committee (e.g., the effort
[started](https://github.com/j3-fortran/fortran_proposals/issues/104) at the J3
committee repository) and the plan is to continue working with the Committee in
the future (such as in the step 5. in the [Workflow](page/contributing/Workflow.html) document), so
that if the Committee wants to standardize some feature already available in `stdlib`, it would
base it on `stdlib`'s implementation.
Scope
=====
The goal of the Fortran Standard Library is to achieve the following general scope:
* Utilities (containers, strings, files, OS/environment integration, unit
testing & assertions, logging, ...)
* Algorithms (searching and sorting, merging, ...)
* Mathematics (linear algebra, sparse matrices, special functions, fast Fourier
transform, random numbers, statistics, ordinary differential equations,
numerical integration, optimization, ...)
Code of Conduct
===============
In the interest of fostering an open and welcoming environment, we as contributors and maintainers pledge to make participation in our project and our community a harassment-free experience for everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, level of experience, nationality, personal appearance, race, religion, or sexual identity and orientation. Please read first [this Code of Conduct](./page/contributing/CodeOfConduct.html)
License
=======
The `stdlib` source code and related files and documentation are distributed under the [MIT license](page/License.html).
fortran-lang-stdlib-0ede301/fpm.toml 0000664 0001750 0001750 00000000573 15135654166 017652 0 ustar alastair alastair name = "stdlib"
version = "VERSION"
license = "MIT"
author = "stdlib contributors"
maintainer = "@fortran-lang/stdlib"
copyright = "2019-2024 stdlib contributors"
[install]
library = true
[dev-dependencies]
test-drive.git = "https://github.com/fortran-lang/test-drive"
test-drive.tag = "v0.4.0"
[preprocess]
[preprocess.cpp]
suffixes = [".F90", ".f90"]
macros = ["MAXRANK=7"]
fortran-lang-stdlib-0ede301/STYLE_GUIDE.md 0000664 0001750 0001750 00000012524 15135654166 020331 0 ustar alastair alastair # Fortran stdlib Style Guide
Adopting a consistent style can improve code legibility through the choice of good naming conventions.
In addition, style checks will be run during CI to flag any severe non-conformance.
This allows code review discussions to focus on semantics and substance rather than pedantry.
Consistent whitespace usage, and not polluting line endings with trailing white space makes `git diff`s considerably more legible.
This style guide is a living document and proposed changes may be adopted after discussing them and coming to a consensus.
## Use (modern) standard Fortran
* Do not use obsolescent or deleted language features
E.g., `common`, `pause`, `entry`, arithmetic `if` and computed `goto`
* Do not use vendor extensions in the form of non-standard syntax and vendor supplied intrinsic procedures
E.g., `real*8` or `etime()`
## File naming conventions
* Source files should contain at most one `program`, `module`, or `submodule`
* The filename should match the program or module name and have the file extension `.f90` or `.F90` if preprocessing is required
* All included files must use the `.inc` extension. These files should be located in the `include/` directory.
* If the interface and implementation is split using submodules the implementation submodule file should have the same name as the
interface (parent) module but end in `_implementation`
E.g., `string_class.f90` and `string_class_implementation.f90`
* Tests should be added in the `test` subdirectory and have the same name as the module they are testing with the `test_` prefix
added
E.g., `string_class.f90` and `test/test_string_class.f90`
## Indentation & whitespace
By setting and following a convention for indentation and whitespace, code reviews and git-diffs can
focus on the semantics of the proposed changes rather than style and formatting.
* The body of every Fortran construct should be indented by __four (4) spaces__
* Line length *should be limited to 80 characters* and __must not exceed 132__
* Please do not use Tab characters for indentation
* Please remove trailing white space before committing code
## Variable and procedure naming
* Variable and procedure names, as well as Fortran keywords, should be written in lowercase
* Variable and procedure names should be made up of one or more full words separated by an underscore,
for example `has_failed` is preferred over `hasfailed`
* Where conventional and appropriate shortening of a word is used then the underscore may be omitted,
for example `linspace` is preferred over `lin_space`
## Attributes
* Always specify `intent` for dummy arguments.
* Don't use `dimension` attribute to declare arrays because it is more verbose.
Use this:
```
real, allocatable :: a(:), b(:,:)
```
instead of:
```
real, dimension(:), allocatable :: a
```
```
real, dimension(:,:), allocatable :: b
```
When defining many arrays of the same dimension, `dimension` can be used as an exception if it makes the code less verbose.
* If the `optional` attribute is used to declare a dummy argument, it should follow the `intent` attribute.
* For module procedures, it is recommended to declare attributes before the module keyword for better retro compatibility (Projects using CMake versions lower than CMake 3.25.0 are concerned see [Spurious modules](https://gitlab.kitware.com/cmake/cmake/-/issues/18427#note_983426)).
Prefer the following pattern:
```
module
```
instead of:
```
module
```
## End block closing statements
Fortran allows certain block constructs or scopes to include the name of the program unit in the end statement.
The convention adopted herein is to include procedure names, `module` names and `program` names in the `end` statement,
unless the closing statement can reasonably be expected to be on the same screen or page, within about 25 lines.
## Document public API code with FORD
Documentation strings should be provided for all public and protected entities and their arguments or parameters.
This is currently accomplished using the [FORD tool](https://github.com/Fortran-FOSS-Programmers/ford).
For help writing FORD style documentation please see the [FORD wiki](https://github.com/Fortran-FOSS-Programmers/ford/wiki).
The following two sections are most relevant for contributing new code:
* [Writing Documentation](https://github.com/Fortran-FOSS-Programmers/ford/wiki/Writing-Documentation)
* [Documentation Meta Data](https://github.com/Fortran-FOSS-Programmers/ford/wiki/Documentation-Meta-Data)
* [Limitations](https://github.com/Fortran-FOSS-Programmers/ford/wiki/Limitations)
To write the "spec" (specification) for a new proposal, please place it in the
[FORD "pages"](https://github.com/Fortran-FOSS-Programmers/ford/wiki/Writing-Pages) directory at
[`doc/specs/`](https://github.com/fortran-lang/stdlib/tree/HEAD/doc/specs).
To get help please see the ["Writing Pages"](https://github.com/Fortran-FOSS-Programmers/ford/wiki/Writing-Pages)
and ["Writing Documentation"](https://github.com/Fortran-FOSS-Programmers/ford/wiki/Writing-Documentation) pages
on the [FORD wiki](https://github.com/Fortran-FOSS-Programmers/ford/wiki).
fortran-lang-stdlib-0ede301/WORKFLOW.md 0000664 0001750 0001750 00000020051 15135654166 017760 0 ustar alastair alastair # Workflow for the Fortran stdlib contributors
This document describes our current workflow.
We welcome everyone and anyone to participate and propose additions to stdlib.
It is okay if you do not have experience for specification or implementation,
but have an idea for stdlib. If the idea is popular among the community, more
experienced contributors will help it through all 5 steps.
1. **Idea**: You have an idea or a proposal. Open an
[issue](https://github.com/fortran-lang/stdlib/issues) to discuss it. This
is on the level of "is there interest in having image reader/writer
functions in stdlib?" The goal of this step is to find out if the community
is interested in having this functionality as part of stdlib.
2. **API**: When there seems to be significant interest in the proposal (vast
majority of participants think it is a good idea), move on to discuss the
specific API. It's OK to propose the API off the bat if you already have an
idea for it. This step is exploratory and its goal is to find out what the
API should *look* and *feel* like.
3. **Specification**: Discuss the API and iterate. When there is vast majority
approval for the API, move on to implement it and submit a PR. Small PRs are
always better than large. It is OK to implement only a few functions of a
new module, and continue work on the others in a later PR. All new
functionality goes into an "experimental" namespace
(`version: experimental`). As part of the PR, when submitting a new
public facing API, please provide the initial draft of the specification
document as well as the initial reference implementation of this
specification. The
[specification is a document](https://stdlib.fortran-lang.org/page/specs/index.html)
that describes the API and
the functionality, so that anyone can use it to create an implementation
from scratch without looking at `stdlib`. The `stdlib` library then provides
the reference implementation.
4. **Implementation** in experimental: When opening a PR, request reviews from
one or more people that are most relevant to it. These are likely to be
people involved in prior steps of the workflow. Other contributors (not
explicitly invited) are encouraged to provide reviews and suggestions as
well. Iterate until all (or most) participants are on the same page.
A merge is permitted if there are unit tests for a majority of the possible
calling scenarios (with or without optional arguments, with arguments that
trigger an error) and if there is vast majority approval of the PR.
5. **Release**: Moving from experimental to release. The experimental
"namespace" contains new functionality together with its specification. In
order to move from experimental to release, the specification document must
be approved by the wide community and the standards committee (informally).
If that happens, it has now been blessed for broad use and we can move the
code into the main section of `stdlib`, and the particular specification
document becomes part of the Fortran Standard Library.
Note: the general term "vast majority" above means at least 80%, but ultimately
it is left to our best judgement to ensure that the community agrees that each
PR and proposal was approved by "vast majority".
You are welcome to propose changes to this workflow by opening an
[issue](https://github.com/fortran-lang/stdlib/issues).
## Build systems
This project supports two build systems,
[fpm](https://github.com/fortran-lang/fpm) and CMake.
### CMake build files
The build files for CMake allow both in-tree, *i.e.* build artifacts share
the same tree as the source files, and out-of-tree builds, *i.e.* build artifacts
exist in a separate directory tree.
Both build types are explicitly supported and tested, the latter strategy
is recommended for local development.
Sources for the main library target are added in ``src/CMakeLists.txt``
relative to the library target, *i.e.* no absolute paths are required.
To add tests, the macro ``ADDTEST`` should be used instead of the CMake function
``add_test``, the macro hides creation of the executable target, linking against the
main library target and registering the test.
The tests themselves are defined as standalone executables in the subdirectories
in ``test``, a new subdirectory with tests has to be registered in
``test/CMakeLists.txt``.
The source tree should be considered read-only. References to ``PROJECT_SOURCE_DIR``
and ``CMAKE_CURRENT_SOURCE_DIR`` should only be used for accessing source files,
never to write build outputs, use ``PROJECT_BINARY_DIR`` and ``CMAKE_CURRENT_BINARY_DIR``
to write build artifacts instead.
To fully support in-tree builds, build artifacts must never have the same name as
source files to avoid accidentally overwriting them, *e.g.* when preprocessing or
configuring a file.
The ``CMAKE_INSTALL_PREFIX`` should only be written to on install, never in the build
process. To install generated files, create a build output in the build tree and
install it with the ``install`` function.
This project follows the GNU install conventions, this means that the variables
``CMAKE_INSTALL_BINDIR``, ``CMAKE_INSTALL_LIBDIR``, and ``CMAKE_INSTALL_INCLUDEDIR``
must be used instead of ``bin``, ``lib``, and ``include``, respectively.
Library targets should be exported on install to allow correct inclusion of the
project in other CMake projects.
Prefer dashes as in ``project-config`` or ``project-targets`` over camel-case as in
``projectConfig`` or ``projectTarget`` for file names as the former allows easier
construction from the ``PROJECT_NAME`` variable by concatenation.
The project is usable as CMake subproject. Explicit references to
``CMAKE_SOURCE_DIR`` and ``CMAKE_BINARY_DIR`` must be avoided to not
break subproject builds.
An example project is available [here](https://github.com/fortran-lang/stdlib-cmake-example)
to test the CMake subproject integration.
## GitHub collaboration
Contributing can be daunting, we know! Even more for a big project with many contributors, and if you are not expert on the whole github workflow then even more, we have been there at some point.
In order to help lowering the barrier for collaborating on ongoing efforts (e.g. an open PR), we have crafted a simple script that might come in handy. To explain the process we'll use Alice (the person you want to help) and Bob (you):
```text
┌────────────────────────────┐
│ fortran-lang/stdlib │
└────────────▲───────────────┘
│
│ [Pull Request]
│
┌───────┴────────┐
│ alice/stdlib │ ←─────┐
└──────▲─────────┘ │
│ │
[PR Branch] ←───┘ ┌──────┴──────┐
feature-branch │ bob/stdlib │
(hosted here) │ (fork) │
└─────────────┘
▲
│
[Push access to Alice's repo]
```
After having forked from `fortran-lang/stdlib` and cloned your `stdlib` fork on your local machine; on an unix compatible terminal with access to the `git` CLI, being at the root folder:
```sh
./.github/collab.sh
```
You will be asked to enter the username and branch of the other person:
```bash
Enter the GitHub username of the fork owner (e.g., alice): alice
Enter the PR branch name (e.g., feature-branch): feature-branch
```
This will fetch Alice's repository and switch your view to Alice's feature-branch. Now you can review, build, run, play around, propose your nice improvements.
Once you finish helping out, you can always `git checkout ` and/or delet Alice's branch from your local view `git branch -d feature-branch`.
Remember, announce your willingness to help 😉
fortran-lang-stdlib-0ede301/README.md 0000664 0001750 0001750 00000051366 15135654166 017460 0 ustar alastair alastair # Fortran Standard Library
[](https://doi.org/10.5281/zenodo.18346789)
[](https://github.com/fortran-lang/stdlib/actions)
[](https://github.com/fortran-lang/stdlib/actions)
* [Goals and Motivation](#goals-and-motivation)
* [Scope](#scope)
* [Getting started](#getting-started)
- [Get the code](#get-the-code)
- [Requirements](#requirements)
- [Supported compilers](#supported-compilers)
- [Build with CMake](#build-with-cmake)
- [Build with fortran-lang/fpm](#build-with-fortran-langfpm)
* [Using stdlib in your project](#using-stdlib-in-your-project)
* [Documentation](#documentation)
* [Contributing](#contributing)
* [Links](#links)
## Goals and Motivation
The Fortran Standard, as published by the ISO (https://wg5-fortran.org/), does
not have a Standard Library. The goal of this project is to provide a community
driven and agreed upon *de facto* "standard" library for Fortran, called a
Fortran Standard Library (`stdlib`). We have a rigorous process how `stdlib` is
developed as documented in our [Workflow](WORKFLOW.md). `stdlib` is both a
specification and a reference implementation. We are cooperating with the
Fortran Standards Committee (e.g., the effort
[started](https://github.com/j3-fortran/fortran_proposals/issues/104) at the J3
committee repository) and the plan is to continue working with the Committee in
the future (such as in the step 5. in the [Workflow](WORKFLOW.md) document), so
that if the Committee wants to standardize some feature already available in `stdlib`, it would
base it on `stdlib`'s implementation.
## Scope
The goal of the Fortran Standard Library is to achieve the following general scope:
* Utilities (containers, strings, files, OS/environment integration, unit
testing & assertions, logging, ...)
* Algorithms (searching and sorting, merging, ...)
* Mathematics (linear algebra, sparse matrices, special functions, fast Fourier
transform, random numbers, statistics, ordinary differential equations,
numerical integration, optimization, ...)
## Getting started
### Get the code
```sh
git clone https://github.com/fortran-lang/stdlib
cd stdlib
```
### Requirements
To build the Fortran standard library you need
- a Fortran 2008 compliant compiler, or better, a Fortran 2018 compliant compiler
(GCC Fortran and Intel Fortran compilers are known to work for stdlib)
- CMake version 3.14 or newer (alternatively Make can be used)
- a build backend for CMake, like Make or Ninja (the latter is recommended on Windows)
- the [fypp](https://github.com/aradi/fypp) preprocessor (used as meta-programming tool)
If your system package manager does not provide the required build tools, all build dependencies can be installed with the Python command line installer ``pip``:
```sh
pip install --user fypp cmake ninja
```
Alternatively, you can install the build tools from the conda-forge channel with the conda package manager:
```sh
conda config --add channels conda-forge
conda create -n stdlib-tools fypp cmake ninja
conda activate stdlib-tools
```
You can install conda using the [miniforge installer](https://github.com/conda-forge/miniforge/releases).
Also, you can install a Fortran compiler from conda-forge by installing the ``fortran-compiler`` package, which installs GFortran.
### Supported Compilers
The following combinations are tested on the default branch of stdlib:
Name | Version | Platform | Architecture
--- | --- | --- | ---
GCC Fortran | 10, 11, 12, 13, 14 | Ubuntu 24.04.3 LTS | x86_64
GCC Fortran | 11, 12, 13, 14, 15 | macOS 14.8.2 (23J126) | Arm64
GCC Fortran (MSYS) | 13 | Windows Server 2022 (10.0.20348 Build 1547) | x86_64
GCC Fortran (MinGW) | 13 | Windows Server 2022 (10.0.20348 Build 1547) | x86_64
Intel oneAPI LLVM | 2024.1 | Ubuntu 24.04.3 LTS | x86_64
Intel oneAPI classic | 2021.10 | Ubuntu 22.04.5 LTS | x86_64
The following combinations are known to work, but they are not tested in the CI:
Name | Version | Platform | Architecture
--- | --- | --- | ---
GCC Fortran (MinGW) | 9.3.0, 10.2.0, 11.2.0 | Windows 10 | x86_64
We try to test as many available compilers and platforms as possible.
A list of tested compilers which are currently not working and the respective issue are listed below.
Name | Version | Platform | Architecture | Status
--- | --- | --- | --- | ---
GCC Fortran | <9 | any | any | [#296](https://github.com/fortran-lang/stdlib/issues/296), [#430](https://github.com/fortran-lang/stdlib/pull/430)
NVIDIA HPC SDK | 20.7, 20.9, 20.11 | Manjaro Linux 20 | x86_64 | [#107](https://github.com/fortran-lang/stdlib/issues/107)
NAG | 7.0 | RHEL | x86_64 | [#108](https://github.com/fortran-lang/stdlib/issues/108)
Intel Parallel Studio XE | 16, 17, 18 | OpenSUSE | x86_64 | failed to compile
Please share your experience with successful and failing builds for compiler/platform/architecture combinations not covered above.
### Build with CMake
Configure the build with
```sh
cmake -B build
```
You can pass additional options to CMake to customize the build.
Important options are
- `-G Ninja` to use the Ninja backend instead of the default Make backend. Other build backends are available with a similar syntax.
- `-DCMAKE_INSTALL_PREFIX` is used to provide the install location for the library. If not provided the defaults will depend on your operating system, [see here](https://cmake.org/cmake/help/latest/variable/CMAKE_INSTALL_PREFIX.html).
- `-DCMAKE_MAXIMUM_RANK` the maximum array rank procedures should be generated for.
The default value is chosen as 4.
The maximum is 15 for Fortran 2003 compliant compilers, otherwise 7 for compilers not supporting Fortran 2003 completely yet.
The minimum required rank to compile this project is 4.
Compiling with maximum rank 15 can be resource intensive and requires at least 16 GB of memory to allow parallel compilation or 4 GB memory for sequential compilation.
- `-DBUILD_SHARED_LIBS` set to `on` in case you want link your application dynamically against the standard library (default: `off`).
- `-DBUILD_TESTING` set to `off` in case you want to disable the stdlib tests (default: `on`).
- `-DCMAKE_VERBOSE_MAKEFILE` is by default set to `Off`, but if set to `On` will show commands used to compile the code.
- `-DCMAKE_BUILD_TYPE` is by default set to `RelWithDebInfo`, which uses compiler flags suitable for code development (but with only `-O2` optimization). Beware the compiler flags set this way will override any compiler flags specified via `FFLAGS`. To prevent this, use `-DCMAKE_BUILD_TYPE=NoConfig` in conjunction with `FFLAGS`.
- `-DFIND_BLAS` set to `off` in case you want to disable finding the external BLAS/LAPACK dependency (default: `on`).
For example, to configure a build using the Ninja backend while specifying compiler optimization via `FFLAGS`, generating procedures up to rank 7, installing to your home directory, using the `NoConfig` compiler flags, and printing the compiler commands, use
```sh
export FFLAGS="-O3"
cmake -B build -G Ninja -DCMAKE_MAXIMUM_RANK:String=7 -DCMAKE_INSTALL_PREFIX=$HOME/.local -DCMAKE_VERBOSE_MAKEFILE=On -DCMAKE_BUILD_TYPE=NoConfig
```
To build the standard library run
```sh
cmake --build build
```
To test your build, run the test suite and all example programs after the build has finished with
```sh
cmake --build build --target test
```
To test only the test suite, run
```sh
ctest --test-dir build/test
```
Please report failing tests on our [issue tracker](https://github.com/fortran-lang/stdlib/issues/new/choose) including details of the compiler used, the operating system and platform architecture.
To install the project to the declared prefix run
```sh
cmake --install build
```
Now you have a working version of stdlib you can use for your project.
If at some point you wish to recompile `stdlib` with different options, you might
want to delete the `build` folder. This will ensure that cached variables from
earlier builds do not affect the new build.
### Build with [fortran-lang/fpm](https://github.com/fortran-lang/fpm)
Fortran Package Manager (fpm) is a package manager and build system for Fortran.
You can build `stdlib` using provided `fpm.toml`:
**Option 1**: From root folder
As `fpm` does not currently support `fypp` natively, `stdlib` now proposes a python script to preprocess and build it.
This script enables modification of the different `fypp` macros available in `stdlib`. The preprocessed files will be dumped at `/temp/*.f90` or `*.F90`.
Make sure to install the dependencies from the `requirement.txt`
```sh
pip install --upgrade -r config/requirements.txt
```
To build, you can use the following command line:
```sh
python config/fypp_deployment.py
fpm build --profile release
```
or the short-cut
```sh
python config/fypp_deployment.py --build
```
To modify the `maxrank` macro for instance:
```sh
python config/fypp_deployment.py --maxrank 7 --build
```
To see all the options:
```sh
python config/fypp_deployment.py --help
```
**Note**: If you use a compiler different than GNU compilers, the script will try to catch it from the environment variables `FPM_FC`, `FPM_CC`, `FPM_CXX`.
**Option 2**: From the `stdlib-fpm` branch which has already been preprocessed with default macros:
```sh
git checkout stdlib-fpm
fpm build --profile release
```
#### Installing with fpm
Either option you chose for building the `stdlib`, you can install it with:
```sh
fpm install --profile release
```
The command above will install the following files:
- `libstdlib.a` into `~/.local/lib/` (Unix) or `C:\Users\\AppData\Roaming\local\lib\` (Windows)
- all the `.[s]mod` files produced by the compiler into `~/.local/include/` (Unix) or `C:\Users\\AppData\Roaming\local\include\` (Windows)
You can change the installation path by setting the prefix option to `fpm`:
```sh
fpm install --profile release --prefix /my/custom/installation/path/
```
You can use the `stdlib` by adding the `-lstdlib` flag to your compiler.
If your prefix is a non standard path, add also:
- `-L/my/custom/installation/path/lib`
- `-I/my/custom/installation/path/include`
#### Running the examples
You can run the examples with `fpm` as:
```sh
fpm run --example prog
```
with `prog` being the name of the example program (e.g., `example_sort`).
### Preprocessing macros and flags
`stdlib` uses two preprocessing steps:
- *fypp* for meta-programming (templating and feature selection)
- *C* preprocessing (activated through compiler flags like `-cpp`(GNU) or `-fpp`(Intel) or use of uppercase file suffix .F90) for conditional compilation
*fypp* preprocessing macros and flags are supported through `CMake` or the `python` script `config/fypp_deployment.py`.
*C* preprocessing macros and flags are supported through `CMake` and `fpm`.
The table below lists all *fypp* preprocessing macros and flags currently used by `stdlib`:
| Macro/flag Name | Comments |
| --- | --- |
| `MAXRANK` | Maximum array rank generated by templates. Set via CMake `-DCMAKE_MAXIMUM_RANK=` (passed to fypp as `-DMAXRANK=`), or via fypp deployment script `--maxrank `. |
| `VERSION90` | Defines the default maximum rank generated when `MAXRANK` is not defined. If defined, the maximum rank generated is 7; otherwise it is 15. Can be passed to fypp as `-DVERSION90` (CMake sets this automatically in some configurations). |
| `WITH_CBOOL` | Enables `c_bool` logical support if available. CMake auto-detects this and passes it to fypp; can be overridden at configure time with `-DWITH_CBOOL=ON/OFF`. |
| `WITH_QP` | Enables quadruple precision code generation (`real(qp)`, `complex(qp)`). CMake auto-detects this and passes it to fypp; can be overridden at configure time with `-DWITH_QP=ON/OFF`; fypp deployment script: `--with_qp`. |
| `WITH_XDP` | Enables extended double precision code generation (`real(xdp)`, `complex(xdp)`). CMake auto-detects this and passes it to fypp; can be overridden at configure time with `-DWITH_XDP=ON/OFF`; fypp deployment script: `--with_xdp`. |
| `WITH_ILP64` | Enables generation of 64-bit integer (ILP64) size interfaces for BLAS and LAPACK (in addition to the default 32-bit interface). Set via CMake `-DWITH_ILP64=True` or via fypp deployment script `--with_ilp64`. |
| `PROJECT_VERSION_MAJOR` | Part of the version string passed into fypp templates. Set automatically by CMake from the file `VERSION`. Can be overridden by passing `-DPROJECT_VERSION_MAJOR=`, or via fypp deployment script `--vmajor `. |
| `PROJECT_VERSION_MINOR` | See `PROJECT_VERSION_MAJOR`. |
| `PROJECT_VERSION_PATCH` | See `PROJECT_VERSION_MAJOR`. |
The table below lists all *C preprocessing* macros and flags currently used by `stdlib`:
| Macro/flag Name | Comments |
| --- | --- |
| `STDLIB_ANSI` | Enables compilation of the `stdlib_ansi` module when set to 1 (default). Set via CMake with `-DSTDLIB_ANSI=On/Off`. |
| `STDLIB_BITSETS` | Enables compilation of the `stdlib_bitsets` module when set to 1 (default). Set via CMake with `-DSTDLIB_BITSETS=On/Off`. |
| `STDLIB_EXTERNAL_BLAS` | Links against an external BLAS (32-bit integer interface). Set automatically by CMake when external BLAS/LAPACK are found, or manually via `add_compile_definitions(STDLIB_EXTERNAL_BLAS)`. In fpm: `preprocess.cpp.macros=["STDLIB_EXTERNAL_BLAS"]`. |
| `STDLIB_EXTERNAL_LAPACK` | Links against an external LAPACK (32-bit integer interface). Usually paired with `STDLIB_EXTERNAL_BLAS`. |
| `STDLIB_EXTERNAL_BLAS_I64` | Links against an external BLAS with ILP64 (64-bit integer) interfaces. Usually paired with `STDLIB_EXTERNAL_LAPACK_I64`. |
| `STDLIB_EXTERNAL_LAPACK_I64` | Links against an external LAPACK with ILP64 (64-bit integer) interfaces. |
| `STDLIB_HASHMAPS` | Enables compilation of the `stdlib_hashmaps` module when set to 1 (default). Set via CMake with `-DSTDLIB_HASHMAPS=On/Off`. |
| `STDLIB_IO` | Enables compilation of the `stdlib_io` module when set to 1 (default). Set via CMake with `-DSTDLIB_IO=On/Off`. |
| `STDLIB_LINALG_ITERATIVE` | Enables compilation of the `stdlib_linalg_iterative_solvers` module when set to 1 (default). Set via CMake with `-DSTDLIB_LINALG_ITERATIVE=On/Off`. |
| `STDLIB_LOGGER` | Enables compilation of the `stdlib_logger` module when set to 1 (default). Set via CMake with `-DSTDLIB_LOGGER=On/Off`. |
| `STDLIB_QUADRATURE` | Enables compilation of the `stdlib_quadrature` module when set to 1 (default). Set via CMake with `-DSTDLIB_QUADRATURE=On/Off`. |
| `STDLIB_SPECIALMATRICES` | Enables compilation of the `stdlib_specialmatrices` module when set to 1 (default). Set via CMake with `-DSTDLIB_SPECIALMATRICES=On/Off`. |
| `STDLIB_STATS` | Enables compilation of the `stdlib_stats` module when set to 1 (default). Set via CMake with `-DSTDLIB_STATS=On/Off`. |
| `STDLIB_STRINGLIST` | Enables compilation of the `stdlib_stringlist` module when set to 1 (default). Set via CMake with `-DSTDLIB_STRINGLIST=On/Off`. |
| `STDLIB_SYSTEM` | Enables compilation of the `stdlib_system` module when set to 1 (default). Set via CMake with `-DSTDLIB_SYSTEM=On/Off`. |
## Using stdlib in your project
### Using stdlib with CMake
The stdlib project exports CMake package files and pkg-config files to make stdlib usable for other projects.
The package files are located in the library directory in the installation prefix.
For CMake builds of stdlib you can find a local installation with
```cmake
find_package(fortran_stdlib REQUIRED)
...
target_link_libraries(
${PROJECT_NAME}
PRIVATE
fortran_stdlib::fortran_stdlib
)
```
To make the installed stdlib project discoverable add the stdlib directory to the ``CMAKE_PREFIX_PATH``.
The usual install location of the package files is ``$PREFIX/lib/cmake/fortran_stdlib``.
### Using stdlib with fpm
To use `stdlib` within your `fpm` project, add the following lines to your `fpm.toml` file:
```toml
[dependencies]
stdlib = { git="https://github.com/fortran-lang/stdlib", branch="stdlib-fpm" }
```
> **Warning**
>
> Fpm 0.9.0 and later implements stdlib as a *metapackage*.
> To include the standard library metapackage, change the dependency to:
> `stdlib = "*"`.
>
> [see also](https://fpm.fortran-lang.org/spec/metapackages.html)
### Using stdlib with a regular Makefile
After the library has been built, it can be included in a regular Makefile.
The recommended way to do this is using the [pkg-config](https://www.freedesktop.org/wiki/Software/pkg-config/) tool, for which an example is shown below.
```make
# Necessary if the installation directory is not in PKG_CONFIG_PATH
install_dir := path/to/install_dir
export PKG_CONFIG_PATH := $(install_dir)/lib/pkgconfig:$(PKG_CONFIG_PATH)
# On some OS the pkgconfig file could be installed in lib64 instead of lib
# export PKG_CONFIG_PATH := $(install_dir)/lib64/pkgconfig:$(PKG_CONFIG_PATH)
STDLIB_CFLAGS := `pkg-config --cflags fortran_stdlib`
STDLIB_LIBS := `pkg-config --libs fortran_stdlib`
# Example definition of Fortran compiler and flags
FC := gfortran
FFLAGS := -O2 -Wall -g
# Definition of targets etc.
...
# Example rule to compile object files from .f90 files
%.o: %.f90
$(FC) -c -o $@ $< $(FFLAGS) $(STDLIB_CFLAGS)
# Example rule to link an executable from object files
%: %.o
$(FC) -o $@ $^ $(FFLAGS) $(STDLIB_LIBS)
```
The same can also be achieved without pkg-config.
If the library has been installed in a directory inside the compiler's search path,
only a flag `-lfortran_stdlib` is required.
If the installation directory is not in the compiler's search path, one can add for example
```make
install_dir := path/to/install_dir
libdir := $(install_dir)/lib
moduledir := $(install_dir)/include/fortran_stdlib/
```
The linker should then look for libraries in `libdir` (using e.g.`-L$(libdir)`) and the compiler should look for module files in `moduledir` (using e.g. `-I$(moduledir)`).
Alternatively, the library can also be included from a build directory without installation with
```make
build_dir := path/to/build_dir
libdir := $(build_dir)/src
moduledir := $(build_dir)/src/mod_files
```
## Documentation
Documentation is a work in progress (see issue [#4](https://github.com/fortran-lang/stdlib/issues/4)) but already available at [stdlib.fortran-lang.org](https://stdlib.fortran-lang.org).
This includes API documentation automatically generated from static analysis and markup comments in the source files
using the [FORD](https://github.com/Fortran-FOSS-programmers/ford/wiki) tool,
as well as a specification document or ["spec"](https://stdlib.fortran-lang.org/page/specs/index.html) for each proposed feature.
Some discussions and prototypes of proposed APIs along with a list of popular open source Fortran projects are available on the
[wiki](https://github.com/fortran-lang/stdlib/wiki).
## BLAS and LAPACK
`stdlib` ships full versions of BLAS and LAPACK, for all `real` and `complex` kinds, through generalized interface modules `stdlib_linalg_blas` and `stdlib_linalg_lapack`.
The 32- and 64-bit implementations may be replaced by external optimized libraries if available, which may allow for faster code.
When linking against external BLAS/LAPACK libraries, the user should define macros `STDLIB_EXTERNAL_BLAS` and `STDLIB_EXTERNAL_LAPACK`,
to ensure that the external library version is used instead of the internal implementation.
- In case of a CMake build, the necessary configuration can be added by ensuring both macros are defined:
```
add_compile_definitions(STDLIB_EXTERNAL_BLAS STDLIB_EXTERNAL_LAPACK)
```
- In case of an `fpm` build, the stdlib dependency should be set as follows:
```toml
[dependencies]
stdlib = { git="https://github.com/fortran-lang/stdlib", branch="stdlib-fpm", preprocess.cpp.macros=["STDLIB_EXTERNAL_BLAS", "STDLIB_EXTERNAL_LAPACK"] }
```
Support for 64-bit integer size interfaces of all BLAS and LAPACK procedures may also be enabled
by setting the CMake flag `-DWITH_ILP64=True`. The 64-bit integer version is always built in addition to
the 32-bit integer version, that is always available. Additional macros `STDLIB_EXTERNAL_BLAS_I64` and `STDLIB_EXTERNAL_LAPACK_I64`
may be defined to link against an external 64-bit integer library, such as Intel MKL.
- In case of an `fpm` build, 64-bit integer linear algebra support is given via branch `stdlib-fpm-ilp64`:
```toml
[dependencies]
stdlib = { git="https://github.com/fortran-lang/stdlib", branch="stdlib-fpm-ilp64", preprocess.cpp.macros=["STDLIB_EXTERNAL_BLAS_I64", "STDLIB_EXTERNAL_LAPACK"] }
```
## Contributing
* [Guidelines](CONTRIBUTING.md)
* [Issues](https://github.com/fortran-lang/stdlib/issues)
* [Workflow](WORKFLOW.md)
* [Style guide](STYLE_GUIDE.md)
* [Code of conduct](CODE_OF_CONDUCT.md)
* [License](LICENSE)
## Links
* [Proposals for the Fortran Standard Committee](https://github.com/j3-fortran/fortran_proposals/)
* [US Fortran Standards Committee](https://j3-fortran.org/)
* [International Fortran Standard Committee](https://wg5-fortran.org/)
fortran-lang-stdlib-0ede301/include/ 0000775 0001750 0001750 00000000000 15135654166 017611 5 ustar alastair alastair fortran-lang-stdlib-0ede301/include/macros.inc 0000664 0001750 0001750 00000002131 15135654166 021565 0 ustar alastair alastair !Default: compile the ansi module
#if !defined STDLIB_ANSI
#define STDLIB_ANSI 1
#endif
!Default: compile the bitsets module
#if !defined STDLIB_BITSETS
#define STDLIB_BITSETS 1
#endif
!Default: compile the hashmaps module
#if !defined STDLIB_HASHMAPS
#define STDLIB_HASHMAPS 1
#endif
!Default: compile the io module
#if !defined STDLIB_IO
#define STDLIB_IO 1
#endif
!Default: compile the linalg_iterative module
#if !defined STDLIB_LINALG_ITERATIVE
#define STDLIB_LINALG_ITERATIVE 1
#endif
!Default: compile the logger module
#if !defined STDLIB_LOGGER
#define STDLIB_LOGGER 1
#endif
!Default: compile the quadrature module
#if !defined STDLIB_QUADRATURE
#define STDLIB_QUADRATURE 1
#endif
!Default: compile the specialmatrices module
#if !defined STDLIB_SPECIALMATRICES
#define STDLIB_SPECIALMATRICES 1
#endif
!Default: compile the stringlist module
#if !defined STDLIB_STRINGLIST
#define STDLIB_STRINGLIST 1
#endif
!Default: compile the system module
#if !defined STDLIB_SYSTEM
#define STDLIB_SYSTEM 1
#endif
!Default: compile the stats module
#if !defined STDLIB_STATS
#define STDLIB_STATS 1
#endif
fortran-lang-stdlib-0ede301/include/common.fypp 0000664 0001750 0001750 00000033561 15135654166 022011 0 ustar alastair alastair #:mute
#! Project version number
#:set PROJECT_VERSION = "{}.{}.{}".format(PROJECT_VERSION_MAJOR, PROJECT_VERSION_MINOR, PROJECT_VERSION_PATCH)
#! Support for C_BOOL logical
#:if not defined("WITH_CBOOL")
#:set WITH_CBOOL = False
#:endif
#! Support for quadruple precision floating point numbers
#:if not defined("WITH_QP")
#:set WITH_QP = False
#:endif
#! Support for extended double precision floating point numbers
#:if not defined("WITH_XDP")
#:set WITH_XDP = False
#:endif
#! Support for linear algebra with 64-bit integer sizes
#:if not defined("WITH_ILP64")
#:set WITH_ILP64 = False
#:endif
#! Real kinds to be considered during templating
#:set REAL_KINDS = ["sp", "dp"]
#:if WITH_XDP
#:set REAL_KINDS = REAL_KINDS + ["xdp"]
#:endif
#:if WITH_QP
#:set REAL_KINDS = REAL_KINDS + ["qp"]
#:endif
#! BLAS/LAPACK initials for each real kind
#:set REAL_INIT = ["s", "d"]
#:if WITH_XDP
#:set REAL_INIT = REAL_INIT + ["x"]
#:endif
#:if WITH_QP
#:set REAL_INIT = REAL_INIT + ["q"]
#:endif
#! Real types to be considered during templating
#:set REAL_TYPES = ["real({})".format(k) for k in REAL_KINDS]
#:set REAL_SUFFIX = REAL_KINDS
#! Real CPPS to be considered during templating
#:set REAL_CPPS = ["" for k in REAL_KINDS]
#! Collected (kind, type) tuples for real types
#:set REAL_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_INIT, REAL_CPPS))
#! Complex kinds to be considered during templating
#:set CMPLX_KINDS = ["sp", "dp"]
#:if WITH_XDP
#:set CMPLX_KINDS = CMPLX_KINDS + ["xdp"]
#:endif
#:if WITH_QP
#:set CMPLX_KINDS = CMPLX_KINDS + ["qp"]
#:endif
#! BLAS/LAPACK initials for each complex kind
#:set CMPLX_INIT = ["c", "z"]
#:if WITH_XDP
#:set CMPLX_INIT = CMPLX_INIT + ["y"]
#:endif
#:if WITH_QP
#:set CMPLX_INIT = CMPLX_INIT + ["w"]
#:endif
#! BLAS/LAPACK complex->real kind initial conversion
#! Converts a BLAS/LAPACK complex kind initial to a real kind initial
#!
#! Args:
#! ci (character): Complex kind initial in ["c","z","y","w"]
#!
#! Returns:
#! Real kind initial in ["s","d","x","q"] or an empty string on invalid input
#!
#:def c2ri(cmplx)
$:"s" if cmplx=="c" else "d" if cmplx=="z" else "x" if cmplx=="y" else "q" if cmplx=="w" else "ERROR"
#:enddef
#! BLAS/LAPACK/Linear Algebra Integer Kinds
#:set LINALG_INT_KINDS = ["ilp"]
#:set LINALG_INT_SUFFIX = [""]
#:if WITH_ILP64
#:set LINALG_INT_KINDS = LINALG_INT_KINDS+["ilp64"]
#:set LINALG_INT_SUFFIX = LINALG_INT_SUFFIX+["_I64"]
#:endif
#:set LINALG_INT_TYPES = ["integer({})".format(k) for k in LINALG_INT_KINDS]
#:set LINALG_INT_KINDS_TYPES = list(zip(LINALG_INT_KINDS, LINALG_INT_TYPES, LINALG_INT_SUFFIX))
#! Complex types to be considered during templating
#:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS]
#:set CMPLX_SUFFIX = ["c{}".format(k) for k in CMPLX_KINDS]
#! Collected (kind, type, initial) tuples for complex types
#:set CMPLX_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_INIT))
#! Integer kinds to be considered during templating
#:set INT_KINDS = ["int8", "int16", "int32", "int64"]
#! Integer types to be considered during templating
#:set INT_TYPES = ["integer({})".format(k) for k in INT_KINDS]
#! Integer abbreviations to be considered during templating
#:set INT_INIT = ["" for k in INT_KINDS]
#! Integer CPPs to be considered during templating
#:set INT_CPPS = ["" for k in INT_KINDS]
#! Collected (kind, type) tuples for integer types
#:set INT_KINDS_TYPES = list(zip(INT_KINDS, INT_TYPES, INT_INIT, INT_CPPS))
#! Logical kinds to be considered during templating
#:set LOG_KINDS = ["lk"]
#:if WITH_CBOOL
#:set LOG_KINDS = LOG_KINDS + ["c_bool"]
#:endif
#! Logical types to be considered during templating
#:set LOG_TYPES = ["logical({})".format(k) for k in LOG_KINDS]
#! Collected (kind, type) tuples for logical types
#:set LOG_KINDS_TYPES = list(zip(LOG_KINDS, LOG_TYPES))
#! Derived type string_type
#:set STRING_KINDS = ["string_type"]
#! String types to be considered during templating
#:set STRING_TYPES = ["type({})".format(k) for k in STRING_KINDS]
#! String abbreviations to be considered during templating
#:set STRING_INIT = ["" for k in STRING_KINDS]
#! String CPPs to be considered during templating
#:set STRING_CPPS = ["" for k in STRING_KINDS]
#! Collected (kind, type) tuples for string derived types
#:set STRING_KINDS_TYPES = list(zip(STRING_KINDS, STRING_TYPES))
#! Derived type bitsets
#:set BITSETS_KINDS = ["bitset_64", "bitset_large"]
#! Bitset types to be considered during templating
#:set BITSETS_TYPES = ["type({})".format(k) for k in BITSETS_KINDS]
#! Bitset abbreviations directive to be considered during templating
#:set BITSETS_INIT = ["" for k in BITSETS_KINDS]
#! Bitset CPP directive to be considered during templating
#:set BITSETS_CPPS = ["STDLIB_BITSETS" for k in BITSETS_KINDS]
#! Collected (kind, type) tuples for bitset types
#:set BITSETS_KINDS_TYPES = list(zip(BITSETS_KINDS, BITSETS_TYPES, BITSETS_INIT, BITSETS_CPPS))
#! Sparse types to be considered during templating
#:set SPARSE_KINDS = ["COO", "CSR", "CSC", "ELL"]
#! Whether Fortran 90 compatible code should be generated
#:set VERSION90 = defined('VERSION90')
#! Ranks to be generated when templates are created
#:if not defined('MAXRANK')
#:if VERSION90
#:set MAXRANK = 7
#:else
#:set MAXRANK = 15
#:endif
#:endif
#! Generates an array rank suffix.
#!
#! Args:
#! rank (int): Rank of the variable
#!
#! Returns:
#! Array rank suffix string (e.g. (:,:) if rank = 2)
#!
#:def ranksuffix(rank)
#{if rank > 0}#(${":" + ",:" * (rank - 1)}$)#{endif}#
#:enddef
#! Generates an empty array rank suffix.
#!
#! Args:
#! rank (int): Rank of the variable
#!
#! Returns:
#! Empty array rank suffix string (e.g. (0,0) if rank = 2)
#!
#:def emptyranksuffix(rank)
#{if rank > 0}#(${"0" + ",0" * (rank - 1)}$)#{endif}#
#:enddef
#! Generates an array rank suffix with a fixed integer size for all dimensions.
#!
#! Args:
#! rank (int): Rank of the variable
#! size (int): Size along each dimension
#!
#! Returns:
#! Array rank suffix string
#! E.g.,
#! fixedranksuffix(3,4)
#! -> (4,4,4)
#!
#:def fixedranksuffix(rank,size)
#{if rank > 0}#(${str(size) + (","+str(size)) * (rank - 1)}$)#{endif}#
#:enddef
#! Joins stripped lines with given character string
#!
#! Args:
#! txt (str): Text to process
#! joinstr (str): String to use as connector
#! prefix (str): String to add as prefix before the joined text
#! suffix (str): String to add as suffix after the joined text
#!
#! Returns:
#! Lines stripped and joined with the given string.
#!
#:def join_lines(txt, joinstr, prefix="", suffix="")
${prefix + joinstr.join([line.strip() for line in txt.split("\n")]) + suffix}$
#:enddef
#! Brace enclosed, comma separated Fortran expressions for a reduced shape.
#!
#! Rank of the original variable will be reduced by one. The routine generates
#! for each dimension a Fortan expression using merge(), which calculates the
#! size of the array for that dimension.
#!
#! Args:
#! varname (str): Name of the variable to be used as origin
#! origrank (int): Rank of the original variable
#! idim (int): Index of the reduced dimension
#!
#! Returns:
#! Shape expression enclosed in braces, so that it can be used as suffix to
#! define array shapes in declarations.
#!
#:def reduced_shape(varname, origrank, idim)
#:assert origrank > 0
#:if origrank > 1
#:call join_lines(joinstr=", ", prefix="(", suffix=")")
#:for i in range(1, origrank)
merge(size(${varname}$, ${i}$), size(${varname}$, ${i + 1}$), mask=${i}$<${idim}$)
#:endfor
#:endcall
#:endif
#:enddef
#! Generates a routine name from a generic name, rank, type and kind
#!
#! Args:
#! gname (str): Generic name
#! rank (integer): Rank if exist
#! type (str): Type of the input
#! kind (str): kind of inputs variable
#! suffix (str): other identifier (could be used for output type/kind)
#!
#! Returns:
#! A string with a new name
#!
#:def rname(gname, rank, type, kind, suffix='')
$:"{0}_{1}_{2}{3}_{2}{3}".format(gname, rank, type[0], kind) if suffix == '' else "{0}_{1}_{2}{3}_{4}".format(gname, rank, type[0], kind, suffix)
#:enddef
#! Generates an array rank suffix for subarrays reducing the dimension
#!
#! Args:
#! rank (int): Rank of the original variable
#! selectors (array): Dimension and name of the variable(s)
#!
#! Returns:
#! Array rank suffix string enclosed in braces
#!
#! E.g.,
#! select_subarray(5 , [(4, 'i'), (5, 'j')])
#! -> (:, :, :, i, j)
#!
#:def select_subarray(rank, selectors)
#:assert rank > 0
#:set seldict = dict(selectors)
#:call join_lines(joinstr=", ", prefix="(", suffix=")")
#:for i in range(1, rank + 1)
$:seldict.get(i, ":")
#:endfor
#:endcall
#:enddef
#!
#! Generates an array rank suffix for subarrays along a dimension
#!
#! Args:
#! varname (str): Name of the variable to be used as origin
#! rank (int): Rank of the original variable
#! dim (int): Dimension of the variable
#!
#! Returns:
#! Array rank suffix string enclosed in braces
#!
#! E.g.,
#! select_subvector('j', 5, 2)
#! -> (j1, :, j3, j4, j5)
#!
#! Used, e.g., in
#! stdlib_stats_median.fypp
#!
#:def select_subvector(varname, rank, idim)
#:assert rank > 0
#:call join_lines(joinstr=", ", prefix="(", suffix=")")
#:for i in range(1, idim)
${varname}$${i}$
#:endfor
:
#:for i in range(idim + 1, rank + 1)
${varname}$${i}$
#:endfor
#:endcall
#:enddef
#!
#! Generates an array rank suffix for arrays
#!
#! Args:
#! varname (str): Name of the variable to be used as origin
#! rank (int): Rank of the original array variable
#! idim (int): Dimension of the variable dropped
#!
#! Returns:
#! Array rank suffix string enclosed in braces
#!
#! E.g.,
#! reduce_subvector('j', 5, 2)
#! -> (j1, j3, j4, j5)
#!
#! Used, e.g., in
#! stdlib_stats_median.fypp
#!
#:def reduce_subvector(varname, rank, idim)
#:assert rank > 0
#:if rank > 1
#:call join_lines(joinstr=", ", prefix="(", suffix=")")
#:for i in range(1, idim)
${varname}$${i}$
#:endfor
#:for i in range(idim + 1, rank + 1)
${varname}$${i}$
#:endfor
#:endcall
#:endif
#:enddef
#!
#! Generates a list of loop variables
#!
#! Args:
#! varname(str): Name of the variable to be used as prefix
#! n (int): Number of loop variables to be created
#! offset (int): Optional index offset
#!
#! Returns:
#! Variable definition string
#!
#! E.g.,
#! loop_variables('j', 5)
#! -> "j1, j2, j3, j4, j5
#!
#:def loop_variables(varname, n, offset=0)
#:assert n > 0
#:call join_lines(joinstr=", ")
#:for i in range(1, n + 1)
${varname}$${i+offset}$
#:endfor
#:endcall
#:enddef
#!
#! Generates a list of loop variables from an array
#!
#! Args:
#! varname(str): Name of the array variable to be used as prefix
#! n (int): Number of loop variables to be created
#! offset (int): Optional index offset
#!
#! Returns:
#! Variable definition string
#!
#! E.g.,
#! loop_array_variables('j', 5)
#! -> "j(1), j(2), j(3), j(4), j(5)
#!
#! loop_array_variables('j', 5, 2)
#! -> "j(3), j(4), j(5), j(6), j(7)
#!
#:def loop_array_variables(varname, n, offset=0)
#:assert n > 0
#:call join_lines(joinstr=", ")
#:for i in range(1, n + 1)
${varname}$(${i+offset}$)
#:endfor
#:endcall
#:enddef
#! Generates an array shape specifier from an N-D array size
#!
#! Args:
#! name (str): Name of the original variable
#! rank (int): Rank of the original variable
#! offset(int): optional offset of the dimension loop (default = 0)
#!
#! Returns:
#! Array rank suffix string enclosed in braces
#!
#! E.g.,
#! shape_from_array_size('mat', 5)}$
#! -> (size(mat,1),size(mat,2),size(mat,3),size(mat,4),size(mat,5))
#! shape_from_array_size('mat', 5, 2)}$
#! -> (size(mat,3),size(mat,4),size(mat,5),size(mat,6),size(mat,7))
#!
#:def shape_from_array_size(name, rank, offset=0)
#:assert rank > 0
#:call join_lines(joinstr=", ", prefix="(", suffix=")")
#:for i in range(1, rank + 1)
size(${name}$,${i+offset}$)
#:endfor
#:endcall
#:enddef
#! Generates an array shape specifier from an N-D array of sizes
#!
#! Args:
#! name (str): Name of the original variable
#! rank (int): Rank of the original variable
#! offset(int): optional offset of the dimension loop (default = 0)
#!
#! Returns:
#! Array rank suffix string enclosed in braces
#!
#! E.g.,
#! shape_from_array_data('mat', 5)}$
#! -> (1:mat(1),1:mat(2),1:mat(3),1:mat(4),1:mat(5))
#! shape_from_array_data('mat', 5, 2)}$
#! -> (1:mat(3),1:mat(4),1:mat(5),1:mat(6),1:mat(7))
#!
#:def shape_from_array_data(name, rank, offset=0)
#:assert rank > 0
#:call join_lines(joinstr=", ", prefix="(", suffix=")")
#:for i in range(1, rank + 1)
1:${name}$(${i+offset}$)
#:endfor
#:endcall
#:enddef
#!
#! Start a sequence of loop with indexed variables over an N-D array
#!
#! Args:
#! varname (str): Name of the variable to be used as prefix
#! matname (str): Name of the variable to be used as array
#! n (int): Number of nested loops to be created (1=innermost; n=outermost)
#! dim_offset (int): Optional dimension offset (1st loop is over dimension 1+dim_offset)
#! intent (str): Optional indentation. Default: 8 spaces
#!
#!
#:def loop_variables_start(varname, matname, n, dim_offset=0, indent=" "*8)
#:assert n > 0
#:for i in range(1, n + 1)
${indent}$do ${varname}$${n+1+dim_offset-i}$ = lbound(${matname}$, ${n+1+dim_offset-i}$), ubound(${matname}$, ${n+1+dim_offset-i}$)
#:endfor
#:enddef
#:def loop_variables_end(n, indent=" "*8)
#:assert n > 0
#:call join_lines(joinstr="; ",prefix=indent)
#:for i in range(1, n + 1)
enddo
#:endfor
#:endcall
#:enddef
#!
#! Encapsulate code into CPP pre-processing directives #ifdef and #endif
#!
#! Args:
#! code (str): Code to be encapsulated
#! cpp_var (str): CPP variable
#!
#:def generate_cpp(code, cpp_var)
#:if cpp_var != ""
#if ${cpp_var}$
#:endif
$:code
#:if cpp_var != ""
#endif
#:endif
#:enddef generate_cpp
#:endmute
fortran-lang-stdlib-0ede301/CONTRIBUTING.md 0000664 0001750 0001750 00000010307 15135654166 020420 0 ustar alastair alastair # Contributing to the Fortran standard library
Thank you for considering contributing to the Fortran standard library (*stdlib*).
Please review and follow these guidelines to make the contribution process
simple and effective for all involved. It will help communicate that you
respect the time of the community developers. In return, the community will
help to address your problem, evaluate changes, and guide you through your pull
requests.
By contributing to *stdlib*, you certify that you own or are allowed to share the
content of your contribution under the
[stdlib license](https://github.com/fortran-lang/stdlib/blob/HEAD/LICENSE).
* [Style](#style)
* [Reporting a bug](#reporting-a-bug)
* [Suggesting a feature](#suggesting-a-feature)
* [Workflow](#workflow)
* [General guidelines](#general-guidelines)
* [For new contributors](#for-new-contributors)
## Style
Please follow the
[Fortran stdlib style guide](https://github.com/fortran-lang/stdlib/blob/HEAD/STYLE_GUIDE.md)
for any Fortran code that you contribute.
This allows the community to focus on substance rather than style.
The style guide is a living document.
You are welcome to propose changes to the style guide by
[opening an issue](https://github.com/fortran-lang/stdlib/issues/new/choose) or
[starting a discussion](https://github.com/fortran-lang/stdlib/discussions/new).
## Reporting a bug
A bug is a *demonstrable problem* caused by the code in this repository.
Good bug reports are extremely valuable to the community—thank you!
Before opening a bug report:
1. Check if the issue has already been reported
([issues](https://github.com/fortran-lang/stdlib/issues)).
2. Check if it is still an issue or it has been fixed?
Try to reproduce it with the latest version from the default branch.
3. Isolate the problem and create a minimal test case.
A good bug report should include all information needed to reproduce the bug.
Please be as detailed as possible:
1. Which version of *stdlib* are you using?
Which compiler version are you using?
Which platform and architecture are you on?
Please be specific.
2. What are the steps to reproduce the issue?
3. What is the expected outcome?
4. What happens instead?
This information will help the community to diagnose the issue quickly and with
minimal back-and-forth.
## Suggesting a feature
Before suggesting a new feature, take a moment to find out if it fits the scope
of the project, or if it has already been discussed. It is up to you to provide
a strong argument to convince the community of the benefits of this feature.
Please provide as many details and context as possible. If applicable, include a
mocked-up snippet of what the output or behavior would look like with this
feature implemented. “Crazy,” out-of-the-box ideas are especially welcome.
It is quite possible we have not considered such solutions yet.
## Workflow
The general workflow is documented in
[this document](https://github.com/fortran-lang/stdlib/blob/HEAD/WORKFLOW.md)
The workflow guide is a living document.
You are welcome to propose changes to the workflow by
[opening an issue](https://github.com/fortran-lang/stdlib/issues/new/choose) or
[starting a discussion](https://github.com/fortran-lang/stdlib/discussions/new).
## General guidelines
* A PR should implement *only one* feature or bug fix.
* Do not commit changes to files that are irrelevant to your feature or bug fix.
* Smaller PRs are better than large PRs, and will lead to a shorter review and
merge cycle.
* Add tests for your feature or bug fix to be sure that it stays functional and useful.
* Include new features and changes in the
[CHANGELOG](https://github.com/fortran-lang/stdlib/blob/master/CHANGELOG.md)
* Be open to constructive criticism and requests for improving your code.
* Again, please follow the
[Fortran stdlib style guide](https://github.com/fortran-lang/stdlib/blob/HEAD/STYLE_GUIDE.md).
## For new contributors
If you have never created a pull request before, welcome :tada:.
You can learn how from
[this great tutorial](https://app.egghead.io/courses/how-to-contribute-to-an-open-source-project-on-github).
Don’t know where to start?
You can start by looking through the list of
[open issues](https://github.com/fortran-lang/stdlib/issues).
fortran-lang-stdlib-0ede301/test/ 0000775 0001750 0001750 00000000000 15135654166 017145 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/stringlist/ 0000775 0001750 0001750 00000000000 15135654166 021347 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/stringlist/test_append_prepend.f90 0000664 0001750 0001750 00000024677 15135654166 025732 0 ustar alastair alastair ! SPDX-Identifier: MIT
module test_append_prepend
use stdlib_error, only: check
use stdlib_string_type, only: string_type, operator(//), operator(==)
use stdlib_stringlist_type, only: stringlist_type, fidx, bidx, list_head, &
& list_tail, operator(//), operator(==), operator(/=)
use stdlib_strings, only: to_string
implicit none
contains
subroutine test_append_prepend_string
type(stringlist_type) :: work_list
type(stringlist_type) :: reference_list
integer :: i
integer, parameter :: first = -100
integer, parameter :: last = 100
character(len=:), allocatable :: string
type(string_type) :: all_strings(first:last)
do concurrent (i=first:last)
all_strings(i) = string_type( to_string(i) )
end do
do i = first, last
string = to_string(i)
work_list = work_list // string
call check( work_list%get( fidx( i - first + 1 ) ) == string_type( string ), &
& "test_append_prepend_string: get fidx( i - first + 1 ) " // string )
end do
call compare_list( work_list, first, last + 1, 1 )
call check( work_list == all_strings, &
& "test_append_prepend_string: work_list ==&
& [ ( string_type( to_string(i) ), i = first, last ) ]" )
call check( all_strings == work_list, &
& "test_append_prepend_string: [ ( string_type( to_string(i) ),&
& i = first, last ) ] == work_list" )
do i = last, first, -1
call check( work_list /= reference_list, "test_append_prepend_string:&
& work_list /= reference_list" )
call check( reference_list /= work_list, "test_append_prepend_string:&
& reference_list /= work_list" )
string = to_string(i)
reference_list = string_type( string ) // reference_list
call check( reference_list%get( bidx( last - i + 1 ) ) == string, &
& "test_append_prepend_string: get bidx( last - i + 1 ) " // string )
end do
call compare_list( reference_list, first, last + 1, 2 )
call check( reference_list == all_strings, "test_append_prepend_string:&
& reference_list == [ ( string_type( to_string(i) ), i = first, last ) ]" )
call check( all_strings == reference_list, &
& "test_append_prepend_string: [ ( string_type( to_string(i) ), i = first, last ) ] == reference_list" )
call check( work_list == reference_list, "test_append_prepend_string:&
& work_list == reference_list" )
call check( reference_list == work_list, "test_append_prepend_string:&
& reference_list == work_list" )
end subroutine test_append_prepend_string
subroutine test_append_prepend_array
type(stringlist_type) :: work_list
type(stringlist_type) :: reference_list
integer :: i, j
integer, parameter :: first = -100
integer, parameter :: last = 100
integer, parameter :: stride = 10
type(string_type) :: all_strings(first:last)
do concurrent (j=first:last)
all_strings(j) = string_type( to_string(j) )
end do
do i = first, last - 1, stride
work_list = work_list // all_strings(i:i+stride-1)
call check( work_list == all_strings(first:i+stride-1), &
& "test_append_prepend_array: work_list ==&
& [ ( string_type( to_string(j) ), j = first, i + stride - 1) ]" )
end do
work_list = work_list // to_string(last)
call compare_list( work_list, first, last + 1, 3 )
call check( work_list == all_strings, &
& "test_append_prepend_array: work_list ==&
& [ ( string_type( to_string(i) ), i = first, last) ]" )
call check( all_strings == work_list, &
& "test_append_prepend_array: [ ( string_type( to_string(i) ), i = first, last) ]&
& == work_list" )
do i = last, first + 1, -1 * stride
call check( work_list /= reference_list, "test_append_prepend_array:&
& work_list /= reference_list" )
call check( reference_list /= work_list, "test_append_prepend_array:&
& reference_list /= work_list" )
reference_list = all_strings(i-stride+1:i) // reference_list
call check( reference_list == all_strings(i-stride+1:last), &
& "test_append_prepend_array: reference_list ==&
& [ ( string_type( to_string(j) ), j = i - stride + 1, last ) ]" )
end do
reference_list = to_string(first) // reference_list
call compare_list( reference_list, first, last + 1, 4 )
call check( all_strings == reference_list, &
& "test_append_prepend_array:&
& [ ( string_type( to_string(i) ), i = first, last) ] == reference_list" )
call check( all_strings == reference_list, &
& "test_append_prepend_array: [ ( string_type( to_string(i) ), i = first, last) ]&
& == reference_list" )
call check( work_list == reference_list, "test_append_prepend_array:&
& work_list == reference_list" )
call check( reference_list == work_list, "test_append_prepend_array:&
& reference_list == work_list" )
end subroutine test_append_prepend_array
subroutine test_append_prepend_list
type(stringlist_type) :: work_list, reference_list
type(stringlist_type) :: temp_list
integer :: i, j
integer, parameter :: first = -100
integer, parameter :: last = 100
integer, parameter :: stride = 10
type(string_type) :: all_strings(first:last)
do concurrent (j=first:last)
all_strings(j) = string_type( to_string(j) )
end do
do i = first, last - 1, stride
call temp_list%clear()
do j = i, i + stride - 1
call temp_list%insert_at( list_tail, string_type( to_string(j) ) )
end do
work_list = work_list // temp_list
call check( work_list == all_strings(first:i+stride-1), &
& "test_append_prepend_list: work_list ==&
& [ ( to_string(j), j = first, i + stride - 1) ]" )
end do
work_list = work_list // to_string(last)
call compare_list( work_list, first, last + 1, 5 )
call check( work_list == all_strings, "test_append_prepend_list:&
& work_list == [ ( string_type( to_string(i) ), i = first, last) ]" )
call check( all_strings == work_list, &
& "test_append_prepend_list: [ ( string_type( to_string(i) ), i = first, last) ]&
& == work_list" )
do i = last, first + 1, -1 * stride
call check( work_list /= reference_list, "test_append_prepend_list:&
& work_list /= reference_list" )
call check( reference_list /= work_list, "test_append_prepend_list:&
& reference_list /= work_list" )
call temp_list%clear()
do j = i - stride + 1, i
call temp_list%insert_at( list_tail, to_string(j) )
end do
reference_list = temp_list // reference_list
call check( reference_list == &
& all_strings(i-stride+1:last), &
& "test_append_prepend_list: reference_list ==&
& [ ( string_type( to_string(j) ), j = i - stride + 1, last ) ]" )
end do
reference_list = to_string(first) // reference_list
call compare_list( reference_list, first, last + 1, 6 )
call check( all_strings == reference_list, &
& "test_append_prepend_list:&
& [ ( string_type( to_string(i) ), i = first, last) ] == reference_list" )
call check( all_strings == reference_list, &
& "test_append_prepend_list: [ ( string_type( to_string(i) ), i = first, last) ]&
& == reference_list" )
call check( work_list == reference_list, "test_append_prepend_list:&
& work_list == reference_list" )
call check( reference_list == work_list, "test_append_prepend_list:&
& reference_list == work_list" )
end subroutine test_append_prepend_list
! compares input stringlist 'list' with an array of consecutive integers
! array is 'first' inclusive and 'last' exclusive
subroutine compare_list(list, first, last, call_number)
type(stringlist_type), intent(in) :: list
integer, intent(in) :: first, last, call_number
integer :: i, j
call check( abs( last - first ) == list%len(), "compare_list: length mis-match&
& call_number " // to_string( call_number ) )
j = merge(-1, 1, last < first)
do i = 1, list%len()
call check( list%get( fidx(i) ) == to_string( first + ( ( i - 1 ) * j ) ), &
& "compare_list: call_number " // to_string( call_number ) &
& // " fidx( " // to_string( i ) // " )")
call check( list%get( bidx(i) ) == to_string( last - ( i * j ) ), &
& "compare_list: call_number " // to_string( call_number ) &
& // " bidx( " // to_string( i ) // " )")
end do
end subroutine compare_list
end module test_append_prepend
program tester
use test_append_prepend
implicit none
call test_append_prepend_string
call test_append_prepend_array
call test_append_prepend_list
end program tester
fortran-lang-stdlib-0ede301/test/stringlist/CMakeLists.txt 0000664 0001750 0001750 00000000053 15135654166 024105 0 ustar alastair alastair ADDTEST(insert_at)
ADDTEST(append_prepend)
fortran-lang-stdlib-0ede301/test/stringlist/test_insert_at.f90 0000664 0001750 0001750 00000042276 15135654166 024731 0 ustar alastair alastair ! SPDX-Identifier: MIT
module test_insert_at
use stdlib_error, only: check
use stdlib_string_type, only: string_type, operator(//), operator(==)
use stdlib_stringlist_type, only: stringlist_type, fidx, bidx, list_head, list_tail, operator(==)
use stdlib_strings, only: to_string
implicit none
contains
subroutine test_insert_at_string_1
type(stringlist_type) :: work_list
integer :: i, current_length
character(len=:), allocatable :: string
integer, parameter :: first = -100
integer, parameter :: last = 1
work_list = stringlist_type()
call check( work_list%len() == 0, "test_insert_at_string_1: constructor" )
write (*,*) "test_insert_at_string_1: Starting test case 1!"
current_length = 0
do i = first, last
string = to_string( i )
call work_list%insert_at( fidx(i), string )
current_length = current_length + 1
call check( work_list%get( fidx(1) ) == string, "test_insert_at_string_1:&
& get fidx(1) " // string )
call check( work_list%get( list_head ) == string, "test_insert_at_string_1:&
& get list_head " // string )
call check( work_list%get( bidx(current_length) ) == string, "test_insert_at_string_1: get&
& bidx(current_length) " // string )
call check( work_list%get( list_tail ) == to_string(first), "test_insert_at_string_1: get&
& list_tail " // string )
call check( work_list%len() == current_length, "test_insert_at_string_1: length check "&
& // to_string( current_length ) )
end do
! compare work_list with [1, 0, -1, ..., ..., -99, -100]
call compare_list( work_list, last, first - 1, 1)
call work_list%clear()
call work_list%clear()
current_length = 0
write (*,*) "test_insert_at_string_1: Starting test case 2!"
do i = first, last
string = to_string( i )
call work_list%insert_at( bidx(i), string )
current_length = current_length + 1
call check( work_list%get( bidx(1) ) == string, "test_insert_at_string_1:&
& get bidx(1) " // string )
call check( work_list%get( list_tail ) == string, "test_insert_at_string_1:&
& get list_tail " // string )
call check( work_list%get( fidx(current_length) ) == string, "test_insert_at_string_1: get&
& fidx(current_length) " // string )
call check( work_list%get( list_head ) == to_string(first), "test_insert_at_string_1: get&
& list_head " // string )
call check( work_list%len() == current_length, "test_insert_at_string_1: length check "&
& // to_string( current_length ) )
end do
! compare work_list with [-100, -99, ..., ..., 0, 1]
call compare_list( work_list, first, last + 1, 2)
end subroutine test_insert_at_string_1
subroutine test_insert_at_string_2
type(stringlist_type) :: work_list
integer :: i, current_length
character(len=:), allocatable :: string
integer, parameter :: first = 2
integer, parameter :: last = 200
write (*,*) "test_insert_at_string_2: Starting test case 1!"
current_length = 0
do i = first, last, 2
string = to_string( i )
call work_list%insert_at( fidx(i), string )
current_length = current_length + 1
call check( work_list%get( fidx(current_length) ) == string, "test_insert_at_string_2:&
& get fidx(current_length) " // string )
call check( work_list%get( fidx(1) ) == to_string(first), "test_insert_at_string_2:&
& get fidx(1) " // string )
call check( work_list%get( list_head ) == to_string(first), "test_insert_at_string_2:&
& get list_head " // string )
call check( work_list%get( bidx(1) ) == string, "test_insert_at_string_2:&
& get bidx(1) " // string )
call check( work_list%get( bidx(current_length) ) == to_string(first), "test_insert_at_string_2: get&
& bidx(current_length) " // string )
call check( work_list%get( list_tail ) == string, "test_insert_at_string_2: get&
& list_tail " // string )
call check( work_list%len() == current_length, "test_insert_at_string_2: length check "&
& // to_string( current_length ) )
end do
write (*,*) "test_insert_at_string_2: Starting test case 2!"
do i = first - 1, last - 1, 2
string = to_string( i )
call work_list%insert_at( fidx(i), string )
current_length = current_length + 1
call check( work_list%get( fidx(i) ) == string, "test_insert_at_string_2:&
& get fidx(current_length) " // string )
call check( work_list%get( fidx(1) ) == to_string(first - 1), "test_insert_at_string_2:&
& get fidx(1) " // string )
call check( work_list%get( list_head ) == to_string(first - 1), "test_insert_at_string_2:&
& get list_head " // string )
call check( work_list%get( bidx(1) ) == to_string(last), "test_insert_at_string_2:&
& get bidx(1) " // string )
call check( work_list%get( bidx(current_length) ) == to_string(first - 1), "test_insert_at_string_2: get&
& bidx(current_length) " // string )
call check( work_list%get( list_tail ) == to_string(last), "test_insert_at_string_2: get&
& list_tail " // string )
call check( work_list%len() == current_length, "test_insert_at_string_2: length check "&
& // to_string( current_length ) )
end do
! compare work_list with [1, 2, ..., ..., 199, 200]
call compare_list( work_list, first - 1, last + 1, 3 )
end subroutine test_insert_at_string_2
subroutine test_insert_at_string_3
type(stringlist_type) :: work_list
integer :: i, current_length
character(len=:), allocatable :: string
integer, parameter :: first = 2
integer, parameter :: last = 200
write (*,*) "test_insert_at_string_3: Starting test case 1!"
current_length = 0
do i = first, last, 2
string = to_string( i )
call work_list%insert_at( bidx(i), string )
current_length = current_length + 1
call check( work_list%get( bidx(current_length) ) == string, "test_insert_at_string_3:&
& get bidx(current_length) " // string )
call check( work_list%get( bidx(1) ) == to_string(first), "test_insert_at_string_3:&
& get bidx(1) " // string )
call check( work_list%get( list_tail ) == to_string(first), "test_insert_at_string_3:&
& get list_tail " // string )
call check( work_list%get( fidx(1) ) == string, "test_insert_at_string_3:&
& get fidx(1) " // string )
call check( work_list%get( fidx(current_length) ) == to_string(first), "test_insert_at_string_3: get&
& fidx(current_length) " // string )
call check( work_list%get( list_head ) == string, "test_insert_at_string_3: get&
& list_head " // string )
call check( work_list%len() == current_length, "test_insert_at_string_3: length check "&
& // to_string( current_length ) )
end do
write (*,*) "test_insert_at_string_3: Starting test case 2!"
do i = first - 1, last - 1, 2
string = to_string( i )
call work_list%insert_at( bidx(i), string )
current_length = current_length + 1
call check( work_list%get( bidx(i) ) == string, "test_insert_at_string_3:&
& get bidx(current_length) " // string )
call check( work_list%get( bidx(1) ) == to_string(first - 1), "test_insert_at_string_3:&
& get bidx(1) " // string )
call check( work_list%get( list_tail ) == to_string(first - 1), "test_insert_at_string_3:&
& get list_tail " // string )
call check( work_list%get( fidx(1) ) == to_string(last), "test_insert_at_string_3:&
& get fidx(1) " // string )
call check( work_list%get( fidx(current_length) ) == to_string(first - 1), "test_insert_at_string_3: get&
& fidx(current_length) " // string )
call check( work_list%get( list_head ) == to_string(last), "test_insert_at_string_3: get&
& list_head " // string )
call check( work_list%len() == current_length, "test_insert_at_string_3: length check "&
& // to_string( current_length ) )
end do
! compare work_list with [200, 199, ..., ..., 2, 1]
call compare_list( work_list, last, first - 2, 4 )
end subroutine test_insert_at_string_3
subroutine test_insert_at_array
type(stringlist_type) :: work_list
type(stringlist_type) :: reference_list
integer :: i, j
integer, parameter :: first = -100
integer, parameter :: last = 100
integer, parameter :: stride = 4
type(string_type) :: all_strings(first:last)
write (*,*) "test_insert_at_array: Starting work_list!"
do concurrent (j=first:last)
all_strings(j) = string_type( to_string(j) )
end do
call work_list%insert_at( list_head, all_strings(first:first+stride-1) )
call compare_list( work_list, first, first + stride, 5 )
call work_list%insert_at( list_tail, all_strings(last-stride:last-1) )
do i = first + stride, last - stride - 1, stride
call work_list%insert_at( fidx( i - first + 1 ), all_strings(i:i+stride-1) )
end do
call work_list%insert_at( list_tail, all_strings(last:last) )
call compare_list( work_list, first, last + 1, 6 )
write (*,*) "test_insert_at_array: Starting reference_list!"
call reference_list%insert_at( list_tail, all_strings (last-stride+1:last) )
call compare_list( reference_list, last - stride + 1, last + 1, 7 )
call reference_list%insert_at( list_head, all_strings(first+1:first+stride) )
do i = last - stride, first + stride + 1, -1 * stride
call reference_list%insert_at( bidx( last - i + 1 ), all_strings(i-stride+1:i) )
end do
call reference_list%insert_at( list_head, all_strings(first:first) )
call compare_list( reference_list, first, last + 1, 8 )
end subroutine test_insert_at_array
subroutine test_insert_at_list
type(stringlist_type) :: work_list, reference_list
type(stringlist_type) :: temp_list
integer :: i, j
integer, parameter :: first = -100
integer, parameter :: last = 100
integer, parameter :: stride = 4
type(string_type) :: all_strings(first:last)
write (*,*) "test_insert_at_list: Starting work_list!"
do concurrent (j=first:last)
all_strings(j) = string_type( to_string(j) )
end do
call temp_list%clear()
do j = first, first + stride - 1
call temp_list%insert_at( list_tail, all_strings(j) )
end do
call work_list%insert_at(list_head, temp_list)
call compare_list( work_list, first, first + stride, 9)
call temp_list%clear()
do j = last - 1, last - stride, -1
call temp_list%insert_at( list_head, all_strings(j) )
end do
call work_list%insert_at(list_tail, temp_list)
do i = first + stride, last - stride - 1, stride
call temp_list%clear()
do j = i, i + stride - 1
call temp_list%insert_at( list_tail, to_string(j) )
end do
call work_list%insert_at( fidx( i - first + 1 ), temp_list )
end do
call temp_list%clear()
call temp_list%insert_at( list_head, all_strings(last) )
call work_list%insert_at( list_tail, temp_list )
call compare_list( work_list, first, last + 1, 10 )
write (*,*) "test_insert_at_list: Starting reference_list!"
call temp_list%clear()
do j = last - stride + 1, last
call temp_list%insert_at( list_tail, to_string(j) )
end do
call reference_list%insert_at( list_tail, temp_list )
call compare_list( reference_list, last - stride + 1, last + 1, 11 )
call temp_list%clear()
do j = first + 1, first + stride
call temp_list%insert_at( list_tail, string_type( to_string(j) ) )
end do
call reference_list%insert_at( list_head, temp_list )
do i = last - stride, first + stride + 1, -1 * stride
call temp_list%clear()
do j = i - stride + 1, i
call temp_list%insert_at( list_tail, to_string(j) )
end do
call reference_list%insert_at( bidx( last - i + 1 ), temp_list )
end do
call temp_list%clear()
call temp_list%insert_at( list_tail, to_string(first) )
call reference_list%insert_at( list_head, temp_list )
call compare_list( reference_list, first, last + 1, 12 )
end subroutine test_insert_at_list
subroutine test_constructor
type(stringlist_type) :: work_list
character(len=4), allocatable :: carray(:)
type(string_type), allocatable :: sarray(:)
write (*,*) "test_constructor: Starting test case 1!"
work_list = stringlist_type()
allocate( carray(0) )
allocate( sarray(0) )
call check( work_list == carray, "test_constructor:&
& test_case 1 work_list == carray" )
call check( work_list == sarray, "test_constructor:&
& test_case 1 work_list == sarray" )
write (*,*) "test_constructor: Starting test case 2!"
carray = [ '#1', '#2', '#3', '#4' ]
sarray = [ string_type('#1'), string_type('#2'), string_type('#3'), string_type('#4') ]
work_list = stringlist_type( carray )
call check( work_list == carray, "test_constructor:&
& test_case 2 work_list == carray" )
call check( work_list == sarray, "test_constructor:&
& test_case 2 work_list == sarray" )
write (*,*) "test_constructor: Starting test case 3!"
work_list = stringlist_type( sarray )
call check( work_list == carray, "test_constructor:&
& test_case 3 work_list == carray" )
call check( work_list == sarray, "test_constructor:&
& test_case 3 work_list == sarray" )
end subroutine test_constructor
! compares input stringlist 'list' with an array of consecutive integers
! array is 'first' inclusive and 'last' exclusive
subroutine compare_list(list, first, last, call_number)
type(stringlist_type), intent(in) :: list
integer, intent(in) :: first, last, call_number
integer :: i, j
call check( abs( last - first ) == list%len(), "compare_list: length mis-match&
& call_number " // to_string( call_number ) )
j = merge(-1, 1, last < first)
do i = 1, list%len()
call check( list%get( fidx(i) ) == to_string( first + ( ( i - 1 ) * j ) ), &
& "compare_list: call_number " // to_string( call_number ) &
& // " fidx( " // to_string( i ) // " )")
call check( list%get( bidx(i) ) == to_string( last - ( i * j ) ), &
& "compare_list: call_number " // to_string( call_number ) &
& // " bidx( " // to_string( i ) // " )")
end do
end subroutine compare_list
end module test_insert_at
program tester
use test_insert_at
implicit none
call test_insert_at_string_1
call test_insert_at_string_2
call test_insert_at_string_3
call test_insert_at_array
call test_insert_at_list
call test_constructor
end program tester
fortran-lang-stdlib-0ede301/test/logger/ 0000775 0001750 0001750 00000000000 15135654166 020424 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/logger/CMakeLists.txt 0000664 0001750 0001750 00000000027 15135654166 023163 0 ustar alastair alastair ADDTEST(stdlib_logger)
fortran-lang-stdlib-0ede301/test/logger/test_stdlib_logger.f90 0000664 0001750 0001750 00000071541 15135654166 024633 0 ustar alastair alastair program test_stdlib_logger
!! A test code for most of stdlib_logger.f90.
use, intrinsic :: &
iso_fortran_env, only : &
error_unit, &
input_unit, &
output_unit
use stdlib_logger, global => global_logger
implicit none
integer, allocatable :: log_units(:)
integer :: level, max_width, stat
integer :: unit1, unit2, unit3, unit4, unit5, unit6
logical :: add_blank_line, exist, indent, time_stamp
if ( global % log_units_assigned() == 0 ) then
write(*,*) 'Start off with 0 LOG_UNITS as expected.'
else
error stop 'Unexpected start off with non_zero LOG_UNITS.'
end if
call test_logging_configuration()
call test_adding_log_files()
print *
print *, 'running test of log_error'
call global % log_error( 'This message should be output to five ' // &
'files and not to OUTPUT_UNIT, limited to 72 columns width, ' // &
'preceded by no blank line, then by a time stamp, then by ' // &
'MODULE % PROCEDURE, be prefixed by ERROR and be indented on ' // &
'subsequent lines by 4 columns, and finish with STAT and.' // &
'ERRMSG lines.', &
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER', &
stat = 0, &
errmsg = 'This is a long ERRMSG intended to test formatting ' // &
'of the ERRMSG when it is more than 72 columns wide.' )
call test_removing_log_units()
print *
print *, 'running log_text_error'
call global % log_text_error( 'This text should be written to UNIT1' // &
' and UNIT3 and not to OUTPUT_UNIT.', &
column = 25, &
summary = 'There is no real error here.', &
filename = 'dummy.txt', &
line_number = 0, &
caret = '1', &
stat = stat )
! call global % assert( 1 < 0, '1 < 0 ; Test of ASSERT', module='N/A', &
! procedure = 'TEST_SDLIB_LOGGER' )
call test_adding_log_units()
print *
print *, 'running log_text_error'
call global % log_text_error( 'This text should be written to ' // &
'UNIT1, UNIT2, and OUTPUT_UNIT.', &
column = 25, &
summary = 'There is no real error here.', &
filename = 'dummy.txt', &
line_number = 0, &
caret = '^', &
stat = stat )
call test_level()
contains
subroutine test_logging_configuration()
print *, 'running test_logging_configuration'
call global % configuration( add_blank_line=add_blank_line, &
indent=indent, max_width=max_width, time_stamp=time_stamp, &
log_units=log_units )
if ( .not. add_blank_line ) then
write(*,*) 'ADD_BLANK_LINE starts off as .FALSE. as expected.'
else
error stop 'ADD_BLANK_LINE starts off as .TRUE. contrary to ' // &
'expectations.'
end if
if ( indent ) then
write(*,*) 'INDENT starts off as .TRUE. as expected.'
else
error stop 'INDENT starts off as .FALSE. contrary to expectations.'
end if
if ( max_width == 0 ) then
write(*,*) 'MAX_WIDTH starts off as 0 as expected.'
else
error stop 'MAX_WIDTH starts off as not equal to 0 contrary ' // &
'to expectations.'
end if
if ( time_stamp ) then
write(*,*) 'TIME_STAMP starts off as .TRUE. as expected.'
else
error stop 'TIME_STAMP starts off as .FALSE. contrary to ' // &
'expectations.'
end if
if ( size(log_units) == 0 ) then
write(*,*) 'SIZE(LOG_UNITS) starts off as 0 as expected.'
else
error stop 'SIZE(LOG_UNITS) starts off as non-zero contrary ' // &
'to expectations.'
end if
!testing all calls independently
call global % configuration( add_blank_line=add_blank_line )
if ( .not. add_blank_line ) then
write(*,*) 'ADD_BLANK_LINE starts off as .FALSE. as expected.'
else
error stop 'ADD_BLANK_LINE starts off as .TRUE. contrary to ' // &
'expectations.'
end if
call global % configuration( indent=indent )
if ( indent ) then
write(*,*) 'INDENT starts off as .TRUE. as expected.'
else
error stop 'INDENT starts off as .FALSE. contrary to expectations.'
end if
call global % configuration( max_width=max_width )
if ( max_width == 0 ) then
write(*,*) 'MAX_WIDTH starts off as 0 as expected.'
else
error stop 'MAX_WIDTH starts off as not equal to 0 contrary ' // &
'to expectations.'
end if
call global % configuration( time_stamp=time_stamp )
if ( time_stamp ) then
write(*,*) 'TIME_STAMP starts off as .TRUE. as expected.'
else
error stop 'TIME_STAMP starts off as .FALSE. contrary to ' // &
'expectations.'
end if
call global % configuration( log_units=log_units )
if ( size(log_units) == 0 ) then
write(*,*) 'SIZE(LOG_UNITS) starts off as 0 as expected.'
else
error stop 'SIZE(LOG_UNITS) starts off as non-zero contrary ' // &
'to expectations.'
end if
call global % log_information( 'This message should be output ' // &
'to OUTPUT_UNIT, unlimited in width, not preceded by ' // &
'a blank line, then by a time stamp, then by MODULE % ' // &
'PROCEDURE, be prefixed by INFO and be indented on ' // &
'subsequent lines by 4 columns.', &
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER' )
call global % log_information( 'This message should be output ' // &
'to OUTPUT_UNIT, unlimited in width, not preceded by ' // &
'a blank line, then by a time stamp, then by MODULE % ' // &
'PROCEDURE, be prefixed by INFO. ' // new_line('a') // &
'This is a new line of the same log message.', &
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER' )
call global % log_debug( 'This message should be output ' // &
'to OUTPUT_UNIT, unlimited in width, not preceded by ' // &
'a blank line, then by a time stamp, then by MODULE % ' // &
'PROCEDURE, be prefixed by DEBUG and be indented on ' // &
'subsequent lines by 4 columns.', &
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER' )
call global % log_debug( 'This message should be output ' // &
'to OUTPUT_UNIT, unlimited in width, not preceded by ' // &
'a blank line, then by a time stamp, then by MODULE % ' // &
'PROCEDURE, be prefixed by DEBUG. ' // new_line('a') // &
'This is a new line of the same log message.', &
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER' )
call global % configure( add_blank_line=.true., indent=.false., &
max_width=72, time_stamp=.false. )
call global % configuration( add_blank_line=add_blank_line, &
indent=indent, max_width=max_width, time_stamp=time_stamp, &
log_units=log_units )
if ( add_blank_line ) then
write(*,*) 'ADD_BLANK_LINE is now .TRUE. as expected.'
else
error stop 'ADD_BLANKLINE is now .FALSE. contrary to expectations.'
end if
if ( .not. indent ) then
write(*,*) 'INDENT is now .FALSE. as expected.'
else
error stop 'INDENT is now .TRUE. contrary to expectations.'
end if
if ( max_width == 72 ) then
write(*,*) 'MAX_WIDTH is now 72 as expected.'
else
error stop 'MAX_WIDTH is not equal to 72 contrary to expectations.'
end if
if ( .not. time_stamp ) then
write(*,*) 'TIME_STAMP is now .FALSE. as expected.'
else
error stop 'TIME_STAMP starts off as .FALSE. contrary to ' // &
'expectations.'
end if
if ( size(log_units) == 0 ) then
write(*,*) 'SIZE(LOG_UNITS) is still 0 as expected.'
else
error stop 'SIZE(LOG_UNITS) is now non-zero contrary to ' // &
'expectations.'
end if
call global % log_message( 'This message should still be output ' // &
'to OUTPUT_UNIT, limited to 72 columns width, preceded by ' // &
'a blank line, then by no time stamp, then by MODULE % ' // &
'PROCEDURE, have no prefix, and be unindented on subsequent ' // &
'lines.', &
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER' )
call global % log_message( 'The last word of the first line ' // &
new_line('a')//'should be "line". "Line"' // new_line('a') // &
'is also the last word for the second line. The following ' // &
'lines should be limited to 72 columns width.' , &
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER' )
call global % configure( add_blank_line=.false., indent=.true., &
max_width=72, time_stamp=.true. )
call global % log_warning( 'This message should still be ' // &
'output to OUTPUT_UNIT, limited to 72 columns width, ' // &
'preceded by no blank line, then by a time stamp, then ' // &
'by MODULE % PROCEDURE, have a prefix of WARN, and be ' // &
'indented by 4 columns on subsequent lines.', &
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER' )
call global % log_message( 'The last word of the first line ' // &
new_line('a')//'should be "the". "Line"' // new_line('a') // &
'should be the last word for the second line. The following ' // &
'lines should be limited to 72 columns width. From the second ' //&
'line, all lines should be indented by 4 columns.' ,&
module = 'N/A', &
procedure = 'TEST_STDLIB_LOGGER' )
end subroutine test_logging_configuration
subroutine test_adding_log_files()
print *
print *, 'running test_adding_log_files'
call global % add_log_file( 'first_log_file.txt', unit1, stat=stat )
if ( stat == success ) then
write(*,*) 'Able to open "first_log_file.txt" as expected'
else
error stop 'Unable to open "first_log_file.txt" contrary to ' // &
'expectations.'
end if
if ( global % log_units_assigned() == 1 ) then
write(*,*) 'Incremented to 1 LOG_UNITS as expected.'
else
error stop 'Unexpected increment to other than 1 LOG_UNITS.'
end if
call global % add_log_file( 'second_log_file.txt', unit2, &
action='readwrite', stat=stat )
if ( stat == success ) then
write(*,*) 'Able to open "second_log_file.txt" as expected'
else
error stop 'Unable to open "second_log_file.txt" contrary to ' // &
'expectations.'
end if
if ( global % log_units_assigned() == 2 ) then
write(*,*) 'Incremented to 2 LOG_UNITS as expected.'
else
error stop 'Unexpected increment to other than 2 LOG_UNITS.'
end if
call global %add_log_file( 'third_log_file.txt', unit3, &
position='asis', stat=stat )
if ( stat == success ) then
write(*,*) 'Able to open "third_log_file.txt" as expected'
else
error stop 'Unable to open "third_log_file.txt" as contrary ' // &
'to expectations.'
end if
if ( global % log_units_assigned() == 3 ) then
write(*,*) 'Incremented to 3 LOG_UNITS as expected.'
else
error stop 'Unexpected increment to other than 3 LOG_UNITS.'
end if
call global % add_log_file( 'fourth_log_file.txt', unit4, &
status='new', stat=stat )
if ( stat /= success ) then
inquire( file='fourth_log_file.txt', exist=exist )
write(*,*) 'Unable to OPEN "fourth_log_file.txt" as "NEW" ' // &
'as it already exists, which is an expected result.'
call global % add_log_file( 'fourth_log_file.txt', unit4, &
status='old', position='rewind', stat=stat )
if ( stat /= success ) then
error stop 'Unable to open "fourth_log_file.txt" as "OLD".'
end if
end if
if ( global % log_units_assigned() == 4 ) then
write(*,*) 'Incremented to 4 LOG_UNITS as expected.'
else
error stop 'Unexpected increment to other than 4 LOG_UNITS.'
end if
call global % add_log_file( 'fifth_log_file.txt', unit5, &
action='READ', stat=stat )
if ( stat /= success ) then
if ( stat == read_only_error ) then
write(*,*) 'Unable to OPEN "fifth_log_file.txt" as ' // &
'"READ", as it makes it read only, which is an ' // &
'expected result.'
call global % add_log_file( 'fifth_log_file.txt', unit5, &
action='write', stat=stat )
if ( stat /= success ) then
error stop 'Unable to open "fifth_log_file.txt" as "WRITE".'
end if
end if
end if
if ( global % log_units_assigned() == 5 ) then
write(*,*) 'Incremented to 5 LOG_UNITS as expected.'
else
error stop 'Unexpected increment to other than 5 LOG_UNITS.'
end if
end subroutine test_adding_log_files
subroutine test_removing_log_units()
logical :: opened
integer :: istat
print *
print *, 'running test_removing_log_units'
call global % remove_log_unit( unit5 )
if ( global % log_units_assigned() == 4 ) then
write(*,*) 'Decremented to 4 LOG_UNITS as expected.'
else
error stop 'Unexpected change to other than 4 LOG_UNITS.'
end if
call global % remove_log_unit( unit5 )
! Should do nothing as already removed
if ( global % log_units_assigned() == 4 ) then
write(*,*) 'Remained at 4 LOG_UNITS as expected.'
else
error stop 'Unexpected change to other than 4 LOG_UNITS.'
end if
inquire( unit4, opened=opened )
if ( opened ) then
write(*,*) 'UNIT4 is OPENED as expected.'
else
error stop 'UNIT4 is not OPENED contrary to expectations.'
end if
call global % remove_log_unit( unit4, close_unit=.true., stat=stat )
if ( stat /= success ) then
error stop 'Unable to close UNIT4 in REMOVE_LOG_UNIT.'
end if
if ( global % log_units_assigned() == 3 ) then
write(*,*) 'Decremented to 3 LOG_UNITS as expected.'
else
error stop 'Unexpected change to other than 3 LOG_UNITS.'
end if
inquire( unit4, opened=opened, iostat=istat )
if(istat /= 0) opened = .false.
if ( opened ) then
error stop 'UNIT4 is opened contrary to expectations.'
else
write(*,*) 'UNIT4 is not opened as expected.'
end if
call global % configuration( log_units=log_units )
if ( unit1 == log_units(1) .and. unit2 == log_units(2) .and. &
unit3 == log_units(3) ) then
write(*,*) 'Units have retained their expected ordering'
else
error stop 'Units have not retained their expected ordering'
end if
call global % remove_log_unit( unit4, close_unit=.true., stat=stat )
if ( stat /= success ) then
error stop 'Attempted to close UNIT4 in REMOVE_LOG_UNIT and failed.'
end if
if ( global % log_units_assigned() == 3 ) then
write(*,*) 'Remained at 3 LOG_UNITS as expected.'
else
error stop 'Unexpected change to other than 3 LOG_UNITS.'
end if
call global % configuration( log_units=log_units )
if ( unit1 == log_units(1) .and. unit2 == log_units(2) .and. &
unit3 == log_units(3) ) then
write(*,*) 'Units have retained their expected ordering'
else
error stop 'Units have not retained their expected ordering'
end if
call global % remove_log_unit( unit2 )
if ( global % log_units_assigned() == 2 ) then
write(*,*) 'Decremented to 2 LOG_UNITS as expected.'
else
error stop 'Unexpected change to other than 2 LOG_UNITS.'
end if
call global % configuration( log_units=log_units )
if ( unit1 == log_units(1) .and. unit3 == log_units(2) ) then
write(*,*) 'Units have their expected placement'
else
error stop 'Units do not have their expected placement'
end if
end subroutine test_removing_log_units
subroutine test_adding_log_units()
print *
print *, 'running test_adding_log_units'
call global % add_log_unit( unit2, stat )
if ( stat == success ) then
if ( global % log_units_assigned() == 3 ) then
write(*,*) 'Successfully added unit2 as expected'
else
error stop 'Adding unit2 failed to increase log_units to 3.'
end if
else
error stop 'Unexpected problem adding unit2.'
end if
call global % add_log_unit( output_unit, stat )
if ( stat == success ) then
if ( global % log_units_assigned() == 4 ) then
write(*,*) 'Successfully added output_unit as expected'
else
error stop 'Adding output_unit failed to increase ' // &
'log_units to 4.'
end if
else
error stop 'Unexpected problem adding output_unit.'
end if
call global % add_log_unit( error_unit, stat )
if ( stat == success ) then
if ( global % log_units_assigned() == 5 ) then
write(*,*) 'Successfully added error_unit as expected'
else
error stop 'Adding error_unit failed to increase ' // &
'log_units to 5.'
end if
else
error stop 'Unexpected problem adding error_unit.'
end if
call global % add_log_unit( input_unit, stat )
if ( stat /= success ) then
if ( global % log_units_assigned() == 5 ) then
write(*,*) 'Failed at adding input_unit as expected'
else
error stop 'Unsuccessfully adding input_unit failed to ' // &
'keep log_units to 5.'
end if
else
error stop 'Unexpected success adding input_unit.'
end if
open( newunit=unit6, file='sixth_log_file.txt', form='formatted', &
action='read', status='replace', position='rewind' )
call global % add_log_unit( unit6, stat )
if ( stat == read_only_error ) then
write(*,*) 'Adding unit6 failed with a READ_ONLY_ERROR as expected'
else
error stop 'Adding unit6 did not fail with a READ_ONLY_ERROR.'
end if
close(unit6)
call global % add_log_unit( unit6, stat )
if ( stat == unopened_in_error ) then
write(*,*) 'Adding unit6 failed with a UNOPENED_IN_ERROR as ' // &
'expected'
else
error stop 'Adding unit6 did not fail with a UNOPENED_IN_ERROR.'
end if
open( newunit=unit6, file='sixth_log_file.txt', form='unformatted', &
action='write', status='replace', position='rewind' )
call global % add_log_unit( unit6, stat )
if ( stat == unformatted_in_error ) then
write(*,*) 'Adding unit6 failed with a UNFORMATTED_IN_ERROR ' // &
'as expected'
else
write(*, *) 'STAT = ', stat
error stop 'Adding unit6 did not fail with a UNFORMATTED_IN_ERROR.'
end if
close(unit6)
open( newunit=unit6, file='sixth_log_file.txt', form='formatted', &
action='write', status='replace', access='direct', recl=100 )
call global % add_log_unit( unit6, stat )
if ( stat == non_sequential_error ) then
write(*,*) 'Adding unit6 failed with a ' // &
'NON_SEQUENTIAL_ERROR as expected'
else
error stop 'Adding unit6 did not fail with a ' // &
'NON_SEQUENTIAL_ERROR.'
end if
close(unit6)
open( newunit=unit6, file='sixth_log_file.txt', form='formatted', &
action='write', status='replace', position='rewind', &
access='sequential' )
call global % add_log_unit( unit6, stat )
if ( stat == success ) then
if ( global % log_units_assigned() == 6 ) then
write(*,*) 'Successfully added unit6 as expected'
else
error stop 'Adding unit6 failed to increase log_units to 6.'
end if
else
error stop 'Unexpected problem adding unit6.'
end if
call global % remove_log_unit( unit6, stat=stat )
if ( stat /= success ) then
error stop 'Unexpected problem removing unit6'
else
if ( global % log_units_assigned() /= 5 ) then
error stop 'Removing unit6 did not decrement log_units to 5.'
else
write(*,*) 'Successfully removed unit6 as expected.'
end if
end if
call global % remove_log_unit( error_unit, stat=stat )
if ( stat /= success ) then
error stop 'Unexpected problem removing error_unit'
else
if ( global % log_units_assigned() /= 4 ) then
error stop 'Removing error_unit did not decrement ' // &
'log_units to 4.'
else
write(*,*) 'Successfully removed error_unit as expected.'
end if
end if
call global % remove_log_unit( unit3, stat=stat )
if ( stat /= success ) then
error stop 'Unexpected problem removing unit3'
else
if ( global % log_units_assigned() /= 3 ) then
error stop 'Removing unit3 did not decrement ' // &
'log_units to 3.'
else
write(*,*) 'Successfully removed unit3 as expected.'
end if
end if
return
end subroutine test_adding_log_units
subroutine test_level()
print *, 'running test_level'
call global % configure( level = all_level )
call global % configuration( level = level )
if ( level == all_level ) then
write(*,*) 'LEVEL is all_level as expected.'
else
error stop 'LEVEL starts off as not equal to all_level ' //&
'contrary to expectations.'
end if
call global % log_message('This message should be always printed, &
& irrespective of the severity level')
call global % log_debug( 'This message should be printed')
call global % log_information( 'This message should be printed')
call global % log_warning( 'This message should be printed')
call global % log_error( 'This message should be printed')
call global % log_io_error( 'This message should be printed')
call global % configure( level = debug_level )
call global % configuration( level = level )
if ( level == debug_level ) then
write(*,*) 'LEVEL is debug_level as expected.'
else
error stop 'LEVEL starts off as not equal to debug_level ' //&
'contrary to expectations.'
end if
call global % log_message('This message should be always printed, &
& irrespective of the severity level')
call global % log_debug( 'This message should be printed')
call global % log_information( 'This message should be printed')
call global % log_warning( 'This message should be printed')
call global % log_error( 'This message should be printed')
call global % log_io_error( 'This message should be printed')
call global % configure( level = information_level )
call global % configuration( level = level )
if ( level == information_level ) then
write(*,*) 'LEVEL is information_level as expected.'
else
error stop 'LEVEL starts off as not equal to information_level ' //&
'contrary to expectations.'
end if
call global % log_message('This message should be always printed, &
& irrespective of the severity level')
call global % log_debug( 'This message should NOT be printed')
call global % log_information( 'This message should be printed')
call global % log_warning( 'This message should be printed')
call global % log_error( 'This message should be printed')
call global % log_io_error( 'This message should be printed')
call global % configure( level = warning_level )
call global % configuration( level = level )
if ( level == warning_level ) then
write(*,*) 'LEVEL is warning_level as expected.'
else
error stop 'LEVEL starts off as not equal to warning_level ' //&
'contrary to expectations.'
end if
call global % log_message('This message should be always printed, &
& irrespective of the severity level')
call global % log_debug( 'This message should NOT be printed')
call global % log_information( 'This message should NOT be printed')
call global % log_warning( 'This message should be printed')
call global % log_error( 'This message should be printed')
call global % log_io_error( 'This message should be printed')
call global % configure( level = error_level )
call global % configuration( level = level )
if ( level == error_level ) then
write(*,*) 'LEVEL is error_level as expected.'
else
error stop 'LEVEL starts off as not equal to error_level ' //&
'contrary to expectations.'
end if
call global % log_message('This message should be always printed, &
& irrespective of the severity level')
call global % log_debug( 'This message should NOT be printed')
call global % log_information( 'This message should NOT be printed')
call global % log_warning( 'This message should NOT be printed')
call global % log_error( 'This message should be printed')
call global % log_io_error( 'This message should be printed')
call global % configure( level = none_level )
call global % configuration( level = level )
if ( level == none_level ) then
write(*,*) 'LEVEL is none_level as expected.'
else
error stop 'LEVEL starts off as not equal to none_level ' //&
'contrary to expectations.'
end if
call global % log_message('This message should be always printed, &
& irrespective of the severity level')
call global % log_debug( 'This message should NOT be printed')
call global % log_information( 'This message should NOT be printed')
call global % log_warning( 'This message should NOT be printed')
call global % log_error( 'This message should NOT be printed')
call global % log_io_error( 'This message should NOT be printed')
print *, 'end of test_level'
end subroutine test_level
end program test_stdlib_logger
fortran-lang-stdlib-0ede301/test/linalg/ 0000775 0001750 0001750 00000000000 15135654166 020413 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/linalg/test_linalg_inverse.fypp 0000664 0001750 0001750 00000025424 15135654166 025362 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test inverse matrix operator
module test_linalg_inverse
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg, only: inv,invert,operator(.inv.),eye
use stdlib_linalg_state, only: linalg_state_type,LINALG_ERROR
implicit none (type,external)
private
public :: test_inverse_matrix
contains
!> Matrix inversion tests
subroutine test_inverse_matrix(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("${ri}$_eye_inverse",test_${ri}$_eye_inverse))
call add_test(tests,new_unittest("${ri}$_singular_inverse",test_${ri}$_singular_inverse))
call add_test(tests,new_unittest("${ri}$_random_spd_inverse",test_${ri}$_random_spd_inverse))
#:endfor
end subroutine test_inverse_matrix
#:for rk,rt,ri in REAL_KINDS_TYPES
!> Invert real identity matrix
subroutine test_${ri}$_eye_inverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp), parameter :: n = 25_ilp
${rt}$ :: a(n,n),inva(n,n)
a = eye(n)
!> Inverse function
inva = inv(a,err=state)
call check(error,state%ok(),'inverse_${ri}$_eye (function): '//state%print())
if (allocated(error)) return
call check(error,all(abs(a-inva) Inverse subroutine: split
call invert(a,inva,err=state)
call check(error,state%ok(),'inverse_${ri}$_eye (subroutine): '//state%print())
if (allocated(error)) return
call check(error,all(abs(a-inva) Inverse subroutine in-place
call invert(a,err=state)
call check(error,state%ok(),'inverse_${ri}$_eye (in-place): '//state%print())
if (allocated(error)) return
call check(error,all(abs(a-inva) Invert singular matrix
subroutine test_${ri}$_singular_inverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: err
integer(ilp), parameter :: n = 25_ilp
${rt}$ :: a(n,n)
a = eye(n)
!> Make rank-deficient
a(12,12) = 0
!> Inverse function
call invert(a,err=err)
call check(error,err%state==LINALG_ERROR,'singular ${rt}$ inverse returned '//err%print())
if (allocated(error)) return
end subroutine test_${ri}$_singular_inverse
!> Create a random symmetric positive definite matrix
function random_spd_matrix_${ri}$(n) result(A)
integer(ilp), intent(in) :: n
${rt}$ :: A(n,n)
${rt}$, parameter :: half = 0.5_${rk}$
!> Initialize with randoms
call random_number(A)
!> Make symmetric
A = half*(A+transpose(A))
!> Add diagonally dominant part
A = A + n*eye(n)
end function random_spd_matrix_${ri}$
!> Test random symmetric positive-definite matrix
subroutine test_${ri}$_random_spd_inverse(error)
type(error_type), allocatable, intent(out) :: error
!> Solution tolerance
${rt}$, parameter :: tol = sqrt(epsilon(0.0_${rk}$))
!> Local variables
integer(ilp), parameter :: n = 5_ilp
type(linalg_state_type) :: state
${rt}$ :: A(n,n),Am1(n,n)
!> Generate random SPD matrix
A = random_spd_matrix_${ri}$(n)
!> Invert matrix
call invert(A,Am1,err=state)
!> Check result
call check(error,state%ok(),'random SPD matrix (${rk}$): '//state%print())
if (allocated(error)) return
call check(error,all(abs(matmul(Am1,A)-eye(n)) Invert complex identity matrix
#:for ck,ct,ci in CMPLX_KINDS_TYPES
subroutine test_${ci}$_eye_inverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp) :: i,j,failed
integer(ilp), parameter :: n = 25_ilp
${ct}$ :: a(n,n),copya(n,n),inva(n,n)
do concurrent (i=1:n,j=1:n)
a(i,j) = merge((1.0_${ck}$,1.0_${ck}$),(0.0_${ck}$,0.0_${ck}$),i==j)
end do
copya = a
!> The inverse of a complex diagonal matrix has conjg(z_ii)/abs(z_ii)^2 on the diagonal
inva = inv(a,err=state)
call check(error,state%ok(),'inverse_${ci}$_eye (function): '//state%print())
if (allocated(error)) return
failed = 0
do i=1,n
do j=1,n
if (.not.is_diagonal_inverse(a(i,j),inva(i,j),i,j)) failed = failed+1
end do
end do
call check(error,failed==0,'inverse_${ci}$_eye (function): data converged')
if (allocated(error)) return
!> Inverse subroutine
call invert(copya,err=state)
call check(error,state%ok(),'inverse_${ci}$_eye (subroutine): '//state%print())
if (allocated(error)) return
failed = 0
do i=1,n
do j=1,n
if (.not.is_diagonal_inverse(a(i,j),copya(i,j),i,j)) failed = failed+1
end do
end do
call check(error,failed==0,'inverse_${ci}$_eye (subroutine): data converged')
if (allocated(error)) return
contains
elemental logical function is_diagonal_inverse(aij,invaij,i,j)
${ct}$, intent(in) :: aij,invaij
integer(ilp), intent(in) :: i,j
if (i/=j) then
is_diagonal_inverse = max(abs(aij),abs(invaij)) Create a random symmetric positive definite matrix
function random_spd_matrix_${ci}$(n) result(A)
integer(ilp), intent(in) :: n
${ct}$ :: A(n,n)
${ct}$, parameter :: half = (0.5_${ck}$,0.0_${ck}$)
real(${ck}$) :: reA(n,n),imA(n,n)
integer(ilp) :: i
!> Initialize with randoms
call random_number(reA)
call random_number(imA)
A = cmplx(reA,imA,kind=${ck}$)
!> Make symmetric
A = half*(A+transpose(A))
!> Add diagonally dominant part
forall(i=1:n) A(i,i) = A(i,i) + n*(1.0_${ck}$,0.0_${ck}$)
end function random_spd_matrix_${ci}$
!> Test random symmetric positive-definite matrix
subroutine test_${ci}$_random_spd_inverse(error)
type(error_type), allocatable, intent(out) :: error
!> Local variables
integer(ilp) :: failed,i,j
integer(ilp), parameter :: n = 5_ilp
type(linalg_state_type) :: state
${ct}$ :: A(n,n),Am1(n,n),AA(n,n)
!> Generate random SPD matrix
A = random_spd_matrix_${ci}$(n)
!> Invert matrix
call invert(A,Am1,err=state)
!> Check result
call check(error,state%ok(),'random complex SPD matrix (${ck}$): '//state%print())
if (allocated(error)) return
failed = 0
AA = matmul(A,Am1)
do i=1,n
do j=1,n
if (.not.is_complex_inverse(AA(i,j),i,j)) failed = failed+1
end do
end do
call check(error,failed==0,'inverse_${ci}$_eye (subroutine): data converged')
if (allocated(error)) return
contains
elemental logical function is_complex_inverse(aij,i,j)
${ct}$, intent(in) :: aij
integer(ilp), intent(in) :: i,j
real(${ck}$), parameter :: tol = sqrt(epsilon(0.0_${ck}$))
if (i/=j) then
is_complex_inverse = abs(aij) Invert singular matrix
subroutine test_${ci}$_singular_inverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: err
integer(ilp), parameter :: n = 25_ilp
${ct}$ :: a(n,n)
a = (0.0_${ck}$,0.0_${ck}$)
!> Inverse function
call invert(a,err=err)
call check(error,err%state==LINALG_ERROR,'singular ${ct}$ inverse returned '//err%print())
if (allocated(error)) return
end subroutine test_${ci}$_singular_inverse
#:endfor
! gcc-15 bugfix utility
subroutine add_test(tests,new_test)
type(unittest_type), allocatable, intent(inout) :: tests(:)
type(unittest_type), intent(in) :: new_test
integer :: n
type(unittest_type), allocatable :: new_tests(:)
if (allocated(tests)) then
n = size(tests)
else
n = 0
end if
allocate(new_tests(n+1))
if (n>0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_inverse
program test_inv
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_inverse, only : test_inverse_matrix
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_inverse", test_inverse_matrix) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_inv
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_expm.fypp 0000664 0001750 0001750 00000011704 15135654166 024654 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test the matrix exponential.
module test_linalg_expm
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_constants
use stdlib_linalg_constants
use stdlib_linalg, only: expm, eye, norm, matrix_exp
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
implicit none (type,external)
public :: test_expm_computation
contains
! gcc-15 bugfix utility
subroutine add_test(tests,new_test)
type(unittest_type), allocatable, intent(inout) :: tests(:)
type(unittest_type), intent(in) :: new_test
integer :: n
type(unittest_type), allocatable :: new_tests(:)
if (allocated(tests)) then
n = size(tests)
else
n = 0
end if
allocate(new_tests(n+1))
if (n>0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
!> Exponent of matrix tests
subroutine test_expm_computation(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
call add_test(tests,new_unittest("expm",test_expm))
call add_test(tests,new_unittest("error_handling_expm",test_error_handling_expm))
end subroutine test_expm_computation
!> Matrix exponential with analytic expression.
subroutine test_expm(error)
type(error_type), allocatable, intent(out) :: error
! Problem dimension.
integer(ilp), parameter :: n = 5, m = 6
! Test matrix.
integer(ilp) :: i, j
#:for rk,rt,ri in RC_KINDS_TYPES
block
${rt}$ :: A(n, n), E(n, n), Eref(n, n)
real(${rk}$) :: err
! Initialize matrix.
A = zero_${rk}$
do i = 1, n-1
A(i, i+1) = m*one_${rk}$
enddo
! Reference with analytical exponential
Eref = eye(n, mold=one_${rk}$)
do i = 1, n-1
do j = 1, n-i
Eref(i, i+j) = Eref(i, i+j-1)*m/j
enddo
enddo
! Compute matrix exponential.
E = expm(A)
! Check result.
err = norm(Eref - E, "inf")
print *, err , (n**2)*epsilon(1.0_${rk}$)
call check(error, err < (n**2)*epsilon(1.0_${rk}$), "Analytical matrix exponential.")
if (allocated(error)) return
end block
#:endfor
end subroutine test_expm
!> Test error handler.
subroutine test_error_handling_expm(error)
type(error_type), allocatable, intent(out) :: error
! Problem dimension.
integer(ilp), parameter :: n = 5, m = 6
! Test matrix.
type(linalg_state_type) :: err
integer(ilp) :: i
#:for rk,rt,ri in RC_KINDS_TYPES
block
${rt}$ :: A(n, n), E(n, n)
! Initialize matrix.
A = zero_${rk}$
do i = 1, n-1
A(i, i+1) = m*one_${rk}$
enddo
! Compute matrix exponential.
call matrix_exp(A, E, order=-1, err=err)
! Check result.
call check(error, err%error(), "Negative Pade order")
if (allocated(error)) return
call matrix_exp(A, order=-1, err=err)
! Check result.
call check(error, err%error(), "Negative Pade order")
if (allocated(error)) return
! Compute matrix exponential.
call matrix_exp(A, E(:n, :n-1), err=err)
! Check result.
call check(error, err%error(), "Invalid matrix size")
if (allocated(error)) return
! Compute matrix exponential.
call matrix_exp(A(:n, :n-1), err=err)
! Check result.
call check(error, err%error(), "Invalid matrix size")
if (allocated(error)) return
end block
#:endfor
end subroutine test_error_handling_expm
end module test_linalg_expm
program test_expm
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_expm, only : test_expm_computation
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_expm", test_expm_computation) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_expm
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_solve_iterative.fypp 0000664 0001750 0001750 00000021433 15135654166 027107 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set MATRIX_TYPES = ["dense", "CSR"]
! Test linear system iterative solvers
module test_linalg_solve_iterative
use stdlib_kinds
use stdlib_sparse
use stdlib_linalg_iterative_solvers
use testdrive, only: error_type, check, new_unittest, unittest_type
implicit none
private
public :: test_linear_systems
contains
subroutine test_linear_systems(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
tests = [ new_unittest("stdlib_solve_cg",test_stdlib_solve_cg), &
new_unittest("stdlib_solve_pcg",test_stdlib_solve_pcg), &
new_unittest("stdlib_solve_bicgstab",test_stdlib_solve_bicgstab), &
new_unittest("stdlib_solve_bicgstab_nonsymmetric",test_stdlib_solve_bicgstab_nonsymmetric) ]
end subroutine test_linear_systems
subroutine test_stdlib_solve_cg(error)
type(error_type), allocatable, intent(out) :: error
#:for k, t, s in R_KINDS_TYPES
block
${t}$, parameter :: tol = 1000*epsilon(0.0_${k}$)
${t}$ :: A(2,2) = reshape([${t}$ :: 4, 1, &
1, 3], [2,2])
${t}$ :: x(2), load(2), xref(2)
xref = [0.0909, 0.6364]
x = real( [2,1] , kind = ${k}$ ) ! initial guess
load = real( [1,2] , kind = ${k}$ ) ! load vector
call stdlib_solve_cg(A, load, x)
call check(error, norm2(x-xref)<1.e-4_${k}$, 'error in conjugate gradient solver')
if (allocated(error)) return
end block
#:endfor
end subroutine test_stdlib_solve_cg
subroutine test_stdlib_solve_pcg(error)
type(error_type), allocatable, intent(out) :: error
#:for k, t, s in R_KINDS_TYPES
block
${t}$, parameter :: tol = 1000*epsilon(0.0_${k}$)
${t}$ :: A(5,5) = reshape([${t}$ :: 1, -1, 0, 0, 0,&
-1, 2, -1, 0, 0,&
0, -1, 2, -1, 0,&
0, 0, -1, 2, -1,&
0, 0, 0, -1, 1] , [5,5])
${t}$ :: x(5), load(5), xref(5)
logical(int8) :: dirichlet(5)
xref = [0.0_${k}$,2.5_${k}$,5.0_${k}$,2.5_${k}$,0.0_${k}$]
x = 0.0_${k}$
load = real( [0,0,5,0,0] , kind = ${k}$ ) ! load vector
dirichlet = .false._int8
dirichlet([1,5]) = .true._int8
call stdlib_solve_pcg(A, load, x, di=dirichlet, rtol=1.e-6_${k}$)
call check(error, norm2(x-xref)<1.e-6_${k}$*norm2(xref), 'error in preconditionned conjugate gradient solver')
if (allocated(error)) return
end block
#:endfor
end subroutine test_stdlib_solve_pcg
subroutine test_stdlib_solve_bicgstab(error)
type(error_type), allocatable, intent(out) :: error
#:for k, t, s in R_KINDS_TYPES
! Test 1: Simple non-symmetric matrix (same as SciPy example)
block
${t}$, parameter :: tol = 1000*epsilon(0.0_${k}$)
${t}$ :: A(4,4) = reshape([${t}$ :: 4, 2, 0, 1, &
3, 0, 0, 2, &
0, 1, 1, 1, &
0, 2, 1, 0], [4,4])
${t}$ :: x(4), load(4), xref(4)
! Reference solution computed with high precision
xref = [12.5_${k}$, -17._${k}$, 23.5_${k}$, -24.5_${k}$]
x = 0.0_${k}$ ! initial guess
load = [-1.0_${k}$, -0.5_${k}$, -1.0_${k}$, 2.0_${k}$] ! load vector
call stdlib_solve_bicgstab(A, load, x, rtol=1.e-10_${k}$)
call check(error, norm2(x-xref) 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_solve_iterative
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_eigenvalues.fypp 0000664 0001750 0001750 00000032712 15135654166 026214 0 ustar alastair alastair #:include "common.fypp"
! Test eigenvalues and eigendecompositions
module test_linalg_eigenvalues
use stdlib_linalg_constants
use stdlib_linalg_state
use stdlib_linalg, only: eig, eigh, eigvals, eigvalsh, diag, eye
use testdrive, only: error_type, check, new_unittest, unittest_type
implicit none (type,external)
private
public :: test_eig_eigh
contains
!> SVD tests
subroutine test_eig_eigh(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in REAL_KINDS_TYPES
call add_test(tests,new_unittest("test_eig_real_${ri}$",test_eig_real_${ri}$))
call add_test(tests,new_unittest("test_eigvals_identity_${ri}$",test_eigvals_identity_${ri}$))
call add_test(tests,new_unittest("test_eigvals_diagonal_B_${ri}$",test_eigvals_diagonal_B_${ri}$))
call add_test(tests,new_unittest("test_eigvals_nondiagonal_B_${ri}$",test_eigvals_nondiagonal_B_${ri}$))
call add_test(tests,new_unittest("test_eigh_real_${ri}$",test_eigh_real_${ri}$))
#: endfor
#:for ck,ct,ci in CMPLX_KINDS_TYPES
call add_test(tests,new_unittest("test_eig_complex_${ci}$",test_eig_complex_${ci}$))
call add_test(tests,new_unittest("test_eig_generalized_complex_${ci}$",test_eigvals_generalized_complex_${ci}$))
call add_test(tests,new_unittest("test_eig_issue_927_${ci}$",test_issue_927_${ci}$))
#: endfor
end subroutine test_eig_eigh
!> Simple real matrix eigenvalues
#:for rk,rt,ri in REAL_KINDS_TYPES
subroutine test_eig_real_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
real(${rk}$), parameter :: zero = 0.0_${rk}$
real(${rk}$), parameter :: two = 2.0_${rk}$
real(${rk}$), parameter :: sqrt2o2 = sqrt(two)*0.5_${rk}$
real(${rk}$), parameter :: tol = sqrt(epsilon(zero))
!> Local variables
type(linalg_state_type) :: state
${rt}$ :: A(3,3),B(2,2)
complex(${rk}$) :: lambda(3),Bvec(2,2),Bres(2,2)
!> Matrix with real eigenvalues
A = reshape([1,0,0, &
0,2,0, &
0,0,3],[3,3])
call eig(A,lambda,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(aimag(lambda)==zero.and.real(lambda,kind=${rk}$)==[1,2,3]),'expected results')
if (allocated(error)) return
!> Matrix with complex eigenvalues
B = transpose(reshape([1, -1, &
1, 1],[2,2]))
!> Expected right eigenvectors
Bres(1,1:2) = sqrt2o2
Bres(2,1) = cmplx(zero,-sqrt2o2,kind=${rk}$)
Bres(2,2) = cmplx(zero,+sqrt2o2,kind=${rk}$)
call eig(B,lambda,right=Bvec,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(Bres-Bvec)<=tol),'expected results')
if (allocated(error)) return
end subroutine test_eig_real_${ri}$
! Symmetric matrix eigenvalues
subroutine test_eigh_real_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
real(${rk}$), parameter :: zero = 0.0_${rk}$
real(${rk}$), parameter :: tol = sqrt(epsilon(zero))
real(${rk}$), parameter :: A(4,4) = reshape([6,3,1,5, &
3,0,5,1, &
1,5,6,2, &
5,1,2,2],[4,4])
!> Local variables
real(${rk}$) :: Amat(4,4),lambda(4),vect(4,4),Av(4,4),lv(4,4)
type(linalg_state_type) :: state
Amat = A
call eigh(Amat,lambda,vect,err=state)
Av = matmul(A,vect)
lv = matmul(vect,diag(lambda))
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(Av-lv)<=tol*abs(Av)),'expected results')
if (allocated(error)) return
!> Test functional versions: no state interface
lambda = eigvalsh(Amat)
!> State interface
lambda = eigvalsh(Amat,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
!> Functional version, lower A
Amat = A
lambda = eigvalsh(Amat,upper_a=.false.,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
end subroutine test_eigh_real_${ri}$
!> Test generalized eigenvalue problem with B = identity
subroutine test_eigvals_identity_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
real(${rk}$), parameter :: zero = 0.0_${rk}$
real(${rk}$), parameter :: tol = sqrt(epsilon(zero))
!> Local variables
type(linalg_state_type) :: state
${rt}$ :: A(3, 3), B(3, 3)
complex(${rk}$) :: lambda(3)
!> Matrix A
A = reshape([3, 0, 0, &
0, 5, 0, &
0, 0, 7], [3, 3])
!> Identity matrix B
B = reshape([1, 0, 0, &
0, 1, 0, &
0, 0, 1], [3, 3])
!> Generalized problem
lambda = eigvals(A, B, err=state)
call check(error, state%ok(), state%print())
if (allocated(error)) return
call check(error, all(abs(real(lambda,${rk}$) - [3, 5, 7]) <= tol), &
'expected results for B=identity')
if (allocated(error)) return
end subroutine test_eigvals_identity_${ri}$
!> Test generalized eigenvalue problem with B = diagonal
subroutine test_eigvals_diagonal_B_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
real(${rk}$), parameter :: zero = 0.0_${rk}$
real(${rk}$), parameter :: tol = sqrt(epsilon(zero))
!> Local variables
type(linalg_state_type) :: state
${rt}$ :: A(3, 3), B(3, 3)
complex(${rk}$) :: lambda(3)
!> Matrix A
A = reshape([3, 0, 0, &
0, 5, 0, &
0, 0, 7], [3, 3])
!> Diagonal matrix B
B = reshape([2, 0, 0, &
0, 4, 0, &
0, 0, 8], [3, 3])
lambda = eigvals(A, B, err=state)
call check(error, state%ok(), state%print())
if (allocated(error)) return
call check(error, all(abs(real(lambda,${rk}$) - [1.5_${rk}$, 1.25_${rk}$, 0.875_${rk}$]) <= tol),&
'expected results for B=diagonal')
if (allocated(error)) return
end subroutine test_eigvals_diagonal_B_${ri}$
!> Test generalized eigenvalue problem with B = non-diagonal
subroutine test_eigvals_nondiagonal_B_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
real(${rk}$), parameter :: zero = 0.0_${rk}$
real(${rk}$), parameter :: tol = 1.0e-3_${rk}$
!> Local variables
type(linalg_state_type) :: state
${rt}$ :: A(3, 3), B(3, 3)
complex(${rk}$) :: lambda(3)
!> Matrix A
A = reshape([3, 2, 0, &
2, 5, 1, &
0, 1, 7], [3, 3])
!> Non-diagonal matrix B
B = reshape([2, 1, 0, &
1, 3, 0, &
0, 0, 4], [3, 3])
lambda = eigvals(A, B, err=state)
call check(error, state%ok(), state%print())
if (allocated(error)) return
call check(error, all(abs(lambda - [1.1734_${rk}$, 1.5766_${rk}$, 2.0000_${rk}$]) <= tol), 'expected results for B=nondiagonal')
print *, 'lambda ',lambda
print *, 'expected ',[1.0,2.5,3.75]
if (allocated(error)) return
end subroutine test_eigvals_nondiagonal_B_${ri}$
#:endfor
!> Simple complex matrix eigenvalues
#:for ck,ct,ci in CMPLX_KINDS_TYPES
subroutine test_eig_complex_${ci}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
real(${ck}$), parameter :: zero = 0.0_${ck}$
real(${ck}$), parameter :: two = 2.0_${ck}$
real(${ck}$), parameter :: sqrt2o2 = sqrt(two)*0.5_${ck}$
real(${ck}$), parameter :: tol = sqrt(epsilon(zero))
${ct}$, parameter :: cone = (1.0_${ck}$,0.0_${ck}$)
${ct}$, parameter :: cimg = (0.0_${ck}$,1.0_${ck}$)
${ct}$, parameter :: czero = (0.0_${ck}$,0.0_${ck}$)
!> Local vaciables
type(linalg_state_type) :: state
${ct}$ :: A(2,2),lambda(2),Avec(2,2),Ares(2,2),lres(2)
!> Matcix with real eigenvalues
A = transpose(reshape([ cone, cimg, &
-cimg, cone], [2,2]))
call eig(A,lambda,right=Avec,err=state)
!> Expected eigenvalues and eigenvectors
lres(1) = two
lres(2) = zero
!> Eigenvectors may vary: do not use for error
Ares(1,1) = cmplx(zero,sqrt2o2,kind=${ck}$)
Ares(1,2) = cmplx(sqrt2o2,zero,kind=${ck}$)
Ares(2,1) = cmplx(sqrt2o2,zero,kind=${ck}$)
Ares(2,2) = cmplx(zero,sqrt2o2,kind=${ck}$)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(lambda-lres)<=tol), 'results match expected')
if (allocated(error)) return
end subroutine test_eig_complex_${ci}$
!> Complex generalized eigenvalue problem with eigvals
subroutine test_eigvals_generalized_complex_${ci}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
real(${ck}$), parameter :: zero = 0.0_${ck}$
real(${ck}$), parameter :: one = 1.0_${ck}$
real(${ck}$), parameter :: tol = sqrt(epsilon(zero))
${ct}$, parameter :: cone = (one, zero)
${ct}$, parameter :: cimg = (zero, one)
${ct}$, parameter :: czero = (zero, zero)
!> Local variables
type(linalg_state_type) :: state
${ct}$ :: A(2,2), B(2,2), lambda(2), lres(2)
!> Matrices A and B for the generalized problem A * x = lambda * B * x
A = transpose(reshape([ cone, cimg, &
-cimg, cone], [2,2]))
B = transpose(reshape([ cone, czero, &
czero, cone], [2,2]))
lambda = eigvals(A, B, err=state)
!> Expected eigenvalues
lres(1) = czero
lres(2) = 2*cone
call check(error, state%ok(), state%print())
if (allocated(error)) return
call check(error, all(abs(lambda - lres) <= tol) .or. &
all(abs(lambda - lres([2,1])) <= tol), 'results match expected')
if (allocated(error)) return
end subroutine test_eigvals_generalized_complex_${ci}$
! Generalized eigenvalues should not crash
subroutine test_issue_927_${ci}$(error)
type(error_type), allocatable, intent(out) :: error
${ct}$ :: A_Z(3,3),S_Z(3,3),vecs_r(3,3),eigs(3)
real(${ck}$) :: A_D(3,3),S_D(3,3)
type(linalg_state_type) :: state
integer :: i
! Set matrix
A_Z = reshape( [ [1, 6, 3], &
[9, 2, 1], &
[8, 3, 4] ], [3,3] )
S_Z = eye(3, mold=0.0_${ck}$)
A_D = real(A_Z)
S_D = real(S_Z)
call eig(A_D,S_D,eigs,right=vecs_r,err=state)
call check(error, state%ok(), 'test issue 927 (${ct}$): '//state%print())
if (allocated(error)) return
call eig(A_Z,S_Z,eigs,right=vecs_r,err=state) !Fails
call check(error, state%ok(), 'test issue 927 (${ct}$): '//state%print())
if (allocated(error)) return
end subroutine test_issue_927_${ci}$
#:endfor
! gcc-15 bugfix utility
subroutine add_test(tests,new_test)
type(unittest_type), allocatable, intent(inout) :: tests(:)
type(unittest_type), intent(in) :: new_test
integer :: n
type(unittest_type), allocatable :: new_tests(:)
if (allocated(tests)) then
n = size(tests)
else
n = 0
end if
allocate(new_tests(n+1))
if (n>0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_eigenvalues
program test_eigenvalues
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_eigenvalues, only : test_eig_eigh
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_eigenvalues", test_eig_eigh) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_eigenvalues
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_mnorm.fypp 0000664 0001750 0001750 00000016034 15135654166 025034 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
module test_linalg_mnorm
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg, only: mnorm, linalg_state_type
use stdlib_linalg_state, only: linalg_state_type
implicit none (type,external)
contains
!> Matrix norm tests
subroutine test_matrix_norms(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("test_matrix_norms_${ri}$",test_matrix_norms_${ri}$))
#:for rank in range(3, MAXRANK)
call add_test(tests,new_unittest("test_mnorm_${ri}$_${rank}$d",test_mnorm_${ri}$_${rank}$d))
#:endfor
#:endfor
end subroutine test_matrix_norms
#:for rk,rt,ri in RC_KINDS_TYPES
!> Test 1-norm, 2-norm (Euclidean), and infinity norm for ${rt}$ matrices
subroutine test_matrix_norms_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp) :: i
integer(ilp), parameter :: mtx_dim = 5
real(${rk}$), parameter :: tol = 10*sqrt(epsilon(0.0_${rk}$))
${rt}$, allocatable :: A(:,:)
type(linalg_state_type) :: err
allocate(A(mtx_dim,mtx_dim))
! Initialize matrix with small values to avoid overflow
A = reshape([(0.01_${rk}$*(i-mtx_dim/2_ilp), i=1_ilp,mtx_dim*mtx_dim)], [mtx_dim,mtx_dim])
! 1-norm (Maximum absolute column sum)
call check(error, abs(mnorm(A, '1', err) - maxval(sum(abs(A), dim=1),1)) < tol*mnorm(A, '1', err), &
'Matrix 1-norm does not match expected value')
if (allocated(error)) return
! 2-norm (Frobenius norm)
call check(error, abs(mnorm(A, err=err) - sqrt(sum(A**2))) < tol*mnorm(A, err=err), &
'Matrix Frobenius norm does not match expected value')
if (allocated(error)) return
! Inf-norm (Maximum absolute row sum)
call check(error, abs(mnorm(A, 'Inf', err) - maxval(sum(abs(A), dim=2),1)) < tol*mnorm(A, 'Inf', err), &
'Matrix Infinity norm does not match expected value')
if (allocated(error)) return
end subroutine test_matrix_norms_${ri}$
#:for rank in range(3, MAXRANK)
!> Test N-D norms
subroutine test_mnorm_${ri}$_${rank}$d(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp) :: i,j,k,l,dim1,dim2,dim(2),dim_sizes(2),ptr(${rank}$)
character(3), parameter :: orders(*) = ['1 ','2 ','fro','inf']
integer(ilp), parameter :: ndim = ${rank}$
integer(ilp), parameter :: n = 2_ilp**ndim
integer(ilp), parameter :: dims(*) = [(dim1, dim1=1,ndim)]
real(${rk}$), parameter :: tol = 10*sqrt(epsilon(0.0_${rk}$))
real(${rk}$) :: one_nrm
real(${rk}$), allocatable :: bnrm${ranksuffix(rank-2)}$
${rt}$, allocatable :: a(:), b${ranksuffix(rank)}$, one_mat(:,:)
character(:), allocatable :: order
character(64) :: msg
allocate(a(n), b${fixedranksuffix(rank,2)}$)
! Init as a range,but with small elements such that all power norms will
! never overflow, even in single precision
a = [(0.01_${rk}$*(j-n/2_ilp), j=1_ilp,n)]
b = reshape(a, shape(b))
! Test norm as collapsed around dimensions
do k = 1, size(orders)
order = trim(orders(k))
do dim1 = 1, ndim
do dim2 = 1, ndim
if (dim1==dim2) cycle
dim = [dim1,dim2]
dim_sizes = [size(b,dim1,kind=ilp),size(b,dim2,kind=ilp)]
! Get norms collapsed on these dims
bnrm = mnorm(b,order,dim)
! Assert size
write(msg,"('dim=[',i0,',',i0,'] order=',a,' ${rk}$ norm returned wrong shape')") dim, order
call check(error,all(shape(bnrm)==pack(shape(b),dims/=dim1 .and. dims/=dim2) ), trim(msg))
if (allocated(error)) return
! Assert some matrix results: check that those on same index i.e. (l,l,l,:,l,l,:) etc.
! are equal to the corresponding 2d-array result
do l = 1, minval(shape(b))
ptr = l
allocate(one_mat(dim_sizes(1),dim_sizes(2)))
do j = 1, dim_sizes(2)
ptr(dim(2)) = j
do i = 1, dim_sizes(1)
ptr(dim(1)) = i
one_mat(i,j) = b(${loop_array_variables('ptr',rank)}$)
end do
end do
one_nrm = mnorm(one_mat,order)
write(msg,"('dim=[',i0,',',i0,'] order=',a,' ${rk}$ ',i0,'-th norm is wrong')") dim, order, l
call check(error, abs(one_nrm-bnrm(${fixedranksuffix(rank-2,'l')}$))0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_mnorm
program test_mnorm
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_mnorm, only : test_matrix_norms
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("matrix_norms", test_matrix_norms) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_mnorm
fortran-lang-stdlib-0ede301/test/linalg/test_blas_lapack.fypp 0000664 0001750 0001750 00000014511 15135654166 024610 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
module test_blas_lapack
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64
use stdlib_linalg, only: eye
use stdlib_linalg_blas
use stdlib_linalg_lapack
implicit none
contains
!> Collect all exported unit tests
subroutine collect_blas_lapack(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
#:for k1, t1 in REAL_KINDS_TYPES
new_unittest("test_gemv${t1[0]}$${k1}$", test_gemv${t1[0]}$${k1}$), &
new_unittest("test_getri${t1[0]}$${k1}$", test_getri${t1[0]}$${k1}$), &
#:endfor
new_unittest("test_idamax", test_idamax), &
new_unittest("test_external_blas",external_blas_test), &
new_unittest("test_external_lapack",external_lapack_test) &
]
end subroutine collect_blas_lapack
#:for k1, t1 in REAL_KINDS_TYPES
subroutine test_gemv${t1[0]}$${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$ :: A(3,3),x(3),y(3),ylap(3),yintr(3),alpha,beta
real(${k1}$), parameter :: tol = 1000 * epsilon(1.0_${k1}$)
call random_number(alpha)
call random_number(beta)
call random_number(A)
call random_number(x)
call random_number(y)
ylap = y
call gemv('No transpose',size(A,1),size(A,2),alpha,A,size(A,1),x,1,beta,ylap,1)
yintr = alpha*matmul(A,x)+beta*y
call check(error, sum(abs(ylap - yintr)) < tol, &
"blas vs. intrinsics axpy: sum() < tol failed")
if (allocated(error)) return
end subroutine test_gemv${t1[0]}$${k1}$
! Find matrix inverse from LU decomposition
subroutine test_getri${t1[0]}$${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: n = 3
${t1}$ :: A(n,n)
${t1}$,allocatable :: work(:)
integer(ilp) :: ipiv(n),info,lwork,nb
real(${k1}$), parameter :: tol = 1000 * epsilon(1.0_${k1}$)
A = eye(n)
! Factorize matrix (overwrite result)
call getrf(size(A,1),size(A,2),A,size(A,1),ipiv,info)
call check(error, info==0, "lapack getrf returned info/=0")
if (allocated(error)) return
! Get optimal worksize (returned in work(1)) (apply 2% safety parameter)
nb = stdlib_ilaenv(1,'${t1[0]}$getri',' ',n,-1,-1,-1)
lwork = nint(1.02*n*nb,kind=ilp)
allocate (work(lwork))
! Invert matrix
call getri(n,a,n,ipiv,work,lwork,info)
call check(error, info==0, "lapack getri returned info/=0")
if (allocated(error)) return
call check(error, sum(abs(A - eye(3))) < tol, &
"lapack eye inversion: tolerance check failed")
if (allocated(error)) return
end subroutine test_getri${t1[0]}$${k1}$
#:endfor
! Return
subroutine test_idamax(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: n = 5
integer(ilp) :: imax
real(dp) :: x(n)
x = [1,2,3,4,5]
imax = stdlib_idamax(n,x,1)
call check(error, imax==5, "blas idamax returned wrong location")
end subroutine test_idamax
!> Test availability of the external BLAS interface
subroutine external_blas_test(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#ifdef STDLIB_EXTERNAL_BLAS
interface
subroutine saxpy(n,sa,sx,incx,sy,incy)
import sp,ilp
implicit none(type,external)
real(sp), intent(in) :: sa,sx(*)
integer(ilp), intent(in) :: incx,incy,n
real(sp), intent(inout) :: sy(*)
end subroutine saxpy
end interface
integer(ilp), parameter :: n = 5, inc=1
real(sp) :: a,x(n),y(n)
x = 1.0_sp
y = 2.0_sp
a = 3.0_sp
call saxpy(n,a,x,inc,y,inc)
call check(error, all(abs(y-5.0_sp) Test availability of the external BLAS interface
subroutine external_lapack_test(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#ifdef STDLIB_EXTERNAL_LAPACK
interface
subroutine dgetrf( m, n, a, lda, ipiv, info )
import dp,ilp
implicit none(type,external)
integer(ilp), intent(out) :: info,ipiv(*)
integer(ilp), intent(in) :: lda,m,n
real(dp), intent(inout) :: a(lda,*)
end subroutine dgetrf
end interface
integer(ilp), parameter :: n = 3
real(dp) :: A(n,n)
integer(ilp) :: ipiv(n),info
A = eye(n)
info = 123
! Factorize matrix
call dgetrf(n,n,A,n,ipiv,info)
call check(error, info==0, "dgetrf: check result")
if (allocated(error)) return
#else
call skip_test(error, "Not using an external LAPACK")
#endif
end subroutine external_lapack_test
end module test_blas_lapack
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_blas_lapack, only : collect_blas_lapack
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("blas_lapack", collect_blas_lapack) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_lstsq.fypp 0000664 0001750 0001750 00000013610 15135654166 025047 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test least squares solver
module test_linalg_least_squares
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg, only: lstsq,solve_lstsq
use stdlib_linalg_state, only: linalg_state_type
implicit none (type,external)
private
public :: test_least_squares
contains
!> Solve sample least squares problems
subroutine test_least_squares(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
call add_test(tests,new_unittest("issue_823",test_issue_823))
#:for rk,rt,ri in REAL_KINDS_TYPES
call add_test(tests,new_unittest("least_squares_${ri}$",test_lstsq_one_${ri}$))
call add_test(tests,new_unittest("least_squares_randm_${ri}$",test_lstsq_random_${ri}$))
#:endfor
end subroutine test_least_squares
#:for rk,rt,ri in REAL_KINDS_TYPES
!> Simple polynomial fit
subroutine test_lstsq_one_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp) :: rank
!> Example scattered data
${rt}$, parameter :: x(*) = real([1.0, 2.5, 3.5, 4.0, 5.0, 7.0, 8.5], ${rk}$)
${rt}$, parameter :: y(*) = real([0.3, 1.1, 1.5, 2.0, 3.2, 6.6, 8.6], ${rk}$)
${rt}$, parameter :: ab(*) = real([0.20925829, 0.12013861], ${rk}$)
${rt}$ :: M(size(x),2),p(2)
! Coefficient matrix for polynomial y = a + b*x**2
M(:,1) = x**0
M(:,2) = x**2
! Find polynomial
p = lstsq(M,y,rank=rank,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(p-ab)<1.0e-4_${rk}$), 'data converged')
if (allocated(error)) return
call check(error, rank==2, 'matrix rank == 2')
if (allocated(error)) return
end subroutine test_lstsq_one_${ri}$
!> Fit from random array
subroutine test_lstsq_random_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp), parameter :: n = 12, m = 3
real :: Arnd(n,m),xrnd(m)
${rt}$, allocatable :: x(:)
${rt}$ :: xsol(m),y(n),A(n,m)
! Random coefficient matrix and solution
call random_number(Arnd)
call random_number(xrnd)
! Compute rhs
A = real(Arnd,${rk}$)
xsol = real(xrnd,${rk}$)
y = matmul(A,xsol)
! Find polynomial
x = lstsq(A,y,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Check size
call check(error,size(x)==m)
if (allocated(error)) return
call check(error, all(abs(x-xsol)<1.0e-4_${rk}$), 'data converged')
if (allocated(error)) return
end subroutine test_lstsq_random_${ri}$
#:endfor
! Test issue #823
subroutine test_issue_823(error)
type(error_type), allocatable, intent(out) :: error
! Dimension of the problem.
integer(ilp), parameter :: n = 42
! Data for the least-squares problem.
complex(dp) :: A(n+1, n), b(n+1), x_true(n), x_lstsq(n)
! Internal variables.
real(dp), allocatable :: tmp(:, :, :), tmp_vec(:, :)
! Error handler
type(linalg_state_type) :: state
! Zero-out data.
A = 0.0_dp
b = 0.0_dp
x_lstsq = 0.0_dp
allocate(tmp(n+1, n, 2), tmp_vec(n, 2), source=0.0_dp)
! Generate a random complex least-squares problem of size (n+1, n).
call random_number(tmp)
call random_number(tmp_vec)
A = cmplx(tmp(:, :, 1), tmp(:, :, 2), kind=dp)
x_true = cmplx(tmp_vec(:, 1), tmp_vec(:, 2), kind=dp)
b = matmul(A, x_true)
! Solve the lstsq problem.
call solve_lstsq(A, b, x_lstsq, err=state)
! Check that no segfault occurred
call check(error,state%ok(),'issue 823 returned '//state%print())
if (allocated(error)) return
! Check that least squares are verified
call check(error,all(abs(x_true-x_lstsq)0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_least_squares
program test_lstsq
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_least_squares, only : test_least_squares
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_least_squares", test_least_squares) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_lstsq
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_pseudoinverse.fypp 0000664 0001750 0001750 00000022640 15135654166 026577 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test Moore-Penrose pseudo matrix inverse
module test_linalg_pseudoinverse
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg
use stdlib_linalg_constants
implicit none (type,external)
private
public :: test_pseudoinverse_matrix
contains
!> Matrix pseudo-inversion tests
subroutine test_pseudoinverse_matrix(tests)
!> Collertion of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in REAL_KINDS_TYPES
call add_test(tests,new_unittest("${ri}$_eye_pseudoinverse",test_${ri}$_eye_pseudoinverse))
#:endfor
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("${ri}$_square_pseudoinverse",test_${ri}$_square_pseudoinverse))
call add_test(tests,new_unittest("${ri}$_tall_pseudoinverse",test_${ri}$_tall_pseudoinverse))
call add_test(tests,new_unittest("${ri}$_wide_pseudoinverse",test_${ri}$_wide_pseudoinverse))
call add_test(tests,new_unittest("${ri}$_singular_pseudoinverse",test_${ri}$_singular_pseudoinverse))
#:endfor
end subroutine test_pseudoinverse_matrix
!> Invert identity matrix
#:for rk,rt,ri in REAL_KINDS_TYPES
subroutine test_${ri}$_eye_pseudoinverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp) :: i,j
integer(ilp), parameter :: n = 15_ilp
real(${rk}$), parameter :: tol = 1000*sqrt(epsilon(0.0_${rk}$))
${rt}$ :: a(n,n),inva(n,n)
do concurrent (i=1:n,j=1:n)
a(i,j) = merge(1.0_${rk}$,0.0_${rk}$,i==j)
end do
!> Invert funrtion
inva = pinv(a,err=state)
call check(error,state%ok(),'${ri}$ pseudoinverse (eye, function): '//state%print())
if (allocated(error)) return
call check(error,all(abs(a-inva) Inverse subroutine
call pseudoinvert(a,inva,err=state)
call check(error,state%ok(),'${ri}$ pseudoinverse (eye, subroutine): '//state%print())
if (allocated(error)) return
call check(error,all(abs(a-inva) Operator
inva = .pinv.a
call check(error,all(abs(a-inva) Test edge case: square matrix
subroutine test_${ri}$_square_pseudoinverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp) :: failed
integer(ilp), parameter :: n = 10
real(${rk}$), parameter :: tol = 1000*sqrt(epsilon(0.0_${rk}$))
${rt}$ :: a(n, n), inva(n, n)
#:if rt.startswith('complex')
real(${rk}$) :: rea(n, n, 2)
call random_number(rea)
a = cmplx(rea(:, :, 1), rea(:, :, 2), kind=${rk}$)
#:else
call random_number(a)
#:endif
inva = pinv(a, err=state)
call check(error,state%ok(),'${ri}$ pseudoinverse (square): '//state%print())
if (allocated(error)) return
failed = count(abs(a - matmul(a, matmul(inva, a))) > tol)
call check(error,failed==0,'${ri}$ pseudoinverse (square, convergence): '//state%print())
if (allocated(error)) return
failed = count(abs(inva - matmul(inva, matmul(a, inva))) > tol)
call check(error,failed==0,'${ri}$ pseudoinverse (square, convergence): '//state%print())
if (allocated(error)) return
end subroutine test_${ri}$_square_pseudoinverse
!> Test edge case: tall matrix
subroutine test_${ri}$_tall_pseudoinverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp) :: failed
integer(ilp), parameter :: m = 20, n = 10
real(${rk}$), parameter :: tol = 1000*sqrt(epsilon(0.0_${rk}$))
${rt}$ :: a(m, n), inva(n, m)
#:if rt.startswith('complex')
real(${rk}$) :: rea(m, n, 2)
call random_number(rea)
a = cmplx(rea(:, :, 1), rea(:, :, 2), kind=${rk}$)
#:else
call random_number(a)
#:endif
inva = pinv(a, err=state)
call check(error,state%ok(),'${ri}$ pseudoinverse (tall): '//state%print())
if (allocated(error)) return
failed = count(abs(a - matmul(a, matmul(inva, a))) > tol)
call check(error,failed==0,'${ri}$ pseudoinverse (tall, convergence): '//state%print())
if (allocated(error)) return
failed = count(abs(inva - matmul(inva, matmul(a, inva))) > tol)
call check(error,failed==0,'${ri}$ pseudoinverse (tall, convergence): '//state%print())
if (allocated(error)) return
end subroutine test_${ri}$_tall_pseudoinverse
!> Test edge case: wide matrix
subroutine test_${ri}$_wide_pseudoinverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp) :: failed
integer(ilp), parameter :: m = 10, n = 20
real(${rk}$), parameter :: tol = 1000*sqrt(epsilon(0.0_${rk}$))
${rt}$ :: a(m, n), inva(n, m)
#:if rt.startswith('complex')
real(${rk}$) :: rea(m, n, 2)
call random_number(rea)
a = cmplx(rea(:, :, 1), rea(:, :, 2), kind=${rk}$)
#:else
call random_number(a)
#:endif
inva = pinv(a, err=state)
call check(error,state%ok(),'${ri}$ pseudoinverse (wide): '//state%print())
if (allocated(error)) return
failed = count(abs(a - matmul(a, matmul(inva, a))) > tol)
call check(error,failed==0,'${ri}$ pseudoinverse (wide, convergence): '//state%print())
if (allocated(error)) return
failed = count(abs(inva - matmul(inva, matmul(a, inva))) > tol)
call check(error,failed==0,'${ri}$ pseudoinverse (wide, convergence): '//state%print())
if (allocated(error)) return
end subroutine test_${ri}$_wide_pseudoinverse
!> Test edge case: singular matrix
subroutine test_${ri}$_singular_pseudoinverse(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp) :: failed
integer(ilp), parameter :: n = 10
real(${rk}$), parameter :: tol = 1000*sqrt(epsilon(0.0_${rk}$))
${rt}$ :: a(n, n), inva(n, n)
#:if rt.startswith('complex')
real(${rk}$) :: rea(n, n, 2)
call random_number(rea)
a = cmplx(rea(:, :, 1), rea(:, :, 2), kind=${rk}$)
#:else
call random_number(a)
#:endif
! Make the matrix singular
a(:, 1) = a(:, 2)
inva = pinv(a, err=state)
call check(error,state%ok(),'${ri}$ pseudoinverse (singular): '//state%print())
if (allocated(error)) return
failed = count(abs(a - matmul(a, matmul(inva, a))) > tol)
call check(error,failed==0,'${ri}$ pseudoinverse (singular, convergence): '//state%print())
if (allocated(error)) return
failed = count(abs(inva - matmul(inva, matmul(a, inva))) > tol)
call check(error,failed==0,'${ri}$ pseudoinverse (singular, convergence): '//state%print())
if (allocated(error)) return
end subroutine test_${ri}$_singular_pseudoinverse
#:endfor
! gcc-15 bugfix utility
subroutine add_test(tests,new_test)
type(unittest_type), allocatable, intent(inout) :: tests(:)
type(unittest_type), intent(in) :: new_test
integer :: n
type(unittest_type), allocatable :: new_tests(:)
if (allocated(tests)) then
n = size(tests)
else
n = 0
end if
allocate(new_tests(n+1))
if (n>0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_pseudoinverse
program test_inv
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_pseudoinverse, only : test_pseudoinverse_matrix
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_pseudoinverse", test_pseudoinverse_matrix) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_inv
fortran-lang-stdlib-0ede301/test/linalg/CMakeLists.txt 0000664 0001750 0001750 00000002652 15135654166 023160 0 ustar alastair alastair set(
fppFiles
"test_linalg.fypp"
"test_linalg_eigenvalues.fypp"
"test_linalg_solve.fypp"
"test_linalg_inverse.fypp"
"test_linalg_pseudoinverse.fypp"
"test_linalg_lstsq.fypp"
"test_linalg_constrained_lstsq.fypp"
"test_linalg_norm.fypp"
"test_linalg_mnorm.fypp"
"test_linalg_determinant.fypp"
"test_linalg_qr.fypp"
"test_linalg_pivoting_qr.fypp"
"test_linalg_schur.fypp"
"test_linalg_solve_iterative.fypp"
"test_linalg_svd.fypp"
"test_linalg_matrix_property_checks.fypp"
"test_linalg_sparse.fypp"
"test_linalg_specialmatrices.fypp"
"test_linalg_cholesky.fypp"
"test_linalg_expm.fypp"
)
# Preprocessed files to contain preprocessor directives -> .F90
set(
cppFiles
"test_blas_lapack.fypp"
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
fypp_f90pp("${fyppFlags}" "${cppFiles}" outPreprocFiles)
ADDTEST(linalg)
ADDTEST(linalg_cholesky)
ADDTEST(linalg_determinant)
ADDTEST(linalg_eigenvalues)
ADDTEST(linalg_expm)
ADDTEST(linalg_matrix_property_checks)
ADDTEST(linalg_inverse)
ADDTEST(linalg_pseudoinverse)
ADDTEST(linalg_norm)
ADDTEST(linalg_mnorm)
ADDTEST(linalg_solve)
ADDTEST(linalg_lstsq)
ADDTEST(linalg_constrained_lstsq)
ADDTEST(linalg_qr)
ADDTEST(linalg_pivoting_qr)
ADDTEST(linalg_schur)
if (STDLIB_LINALG_ITERATIVE)
ADDTEST(linalg_solve_iterative)
endif()
ADDTEST(linalg_svd)
ADDTEST(linalg_sparse)
if (STDLIB_SPECIALMATRICES)
ADDTEST(linalg_specialmatrices)
endif()
ADDTESTPP(blas_lapack)
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_pivoting_qr.fypp 0000664 0001750 0001750 00000027430 15135654166 026247 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test QR factorization
module test_linalg_pivoting_qr
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg_state, only: LINALG_VALUE_ERROR,linalg_state_type
use stdlib_linalg, only: qr, qr_space, mnorm
use ieee_arithmetic, only: ieee_value,ieee_quiet_nan
implicit none (type,external)
public :: test_pivoting_qr_factorization
contains
!> QR factorization tests
subroutine test_pivoting_qr_factorization(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("pivoting_qr_random_tall_matrix_${ri}$",test_pivoting_qr_random_tall_matrix_${ri}$))
call add_test(tests,new_unittest("pivoting_qr_random_rank_deficient_${ri}$",test_pivoting_qr_random_rank_deficient_${ri}$))
call add_test(tests,new_unittest("pivoting_qr_random_wide_matrix_${ri}$",test_pivoting_qr_random_wide_matrix_${ri}$))
#:endfor
end subroutine test_pivoting_qr_factorization
!> QR factorization of a random matrix
#:for rk,rt,ri in RC_KINDS_TYPES
subroutine test_pivoting_qr_random_tall_matrix_${ri}$(error)
use stdlib_linalg, only: hermitian
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: m = 15_ilp
integer(ilp), parameter :: n = 4_ilp
integer(ilp), parameter :: k = min(m,n)
real(${rk}$), parameter :: tol = 100*sqrt(epsilon(0.0_${rk}$))
${rt}$ :: a(m,n),aorig(m,n),q(m,m),r(m,n),qred(m,k),rred(k,n),qerr(m,6),rerr(6,n)
real(${rk}$) :: rea(m,n),ima(m,n)
integer(ilp) :: pivots(n), i, j
integer(ilp) :: lwork
${rt}$, allocatable :: work(:)
type(linalg_state_type) :: state
call random_number(rea)
#:if rt.startswith('complex')
call random_number(ima)
a = cmplx(rea,ima,kind=${rk}$)
#:else
a = rea
#:endif
aorig = a
! 1) QR factorization with full matrices. Input NaNs to be sure Q and R are OK on return
q = ieee_value(0.0_${rk}$,ieee_quiet_nan)
r = ieee_value(0.0_${rk}$,ieee_quiet_nan)
call qr(a, q, r, pivots, err=state)
! Check return code
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Check solution
call check(error, all(abs(a(:, pivots)-matmul(q,r))0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_pivoting_qr
program test_pivoting_qr
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_pivoting_qr, only : test_pivoting_qr_factorization
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_pivoting_qr", test_pivoting_qr_factorization) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_pivoting_qr
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_schur.fypp 0000664 0001750 0001750 00000021102 15135654166 025020 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test Schur decomposition
module test_linalg_schur
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg_state, only: LINALG_VALUE_ERROR,linalg_state_type
use stdlib_linalg, only: schur,schur_space
use ieee_arithmetic, only: ieee_value,ieee_quiet_nan
implicit none (type,external)
public :: test_schur_decomposition
contains
!> schur decomposition tests
subroutine test_schur_decomposition(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("schur_api_${ri}$",test_schur_api_${ri}$))
call add_test(tests,new_unittest("schur_random_${ri}$",test_schur_random_${ri}$))
call add_test(tests,new_unittest("schur_symmetric_${ri}$",test_schur_symmetric_${ri}$))
#:endfor
end subroutine test_schur_decomposition
!> schur decomposition of a random matrix
#:for rk,rt,ri in RC_KINDS_TYPES
subroutine test_schur_api_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: n = 15_ilp
integer(ilp) :: lwork
complex(${rk}$) :: eigs(n)
${rt}$, dimension(n,n) :: a,t,z
${rt}$, allocatable :: storage(:)
#:if 'complex' in rt
real(${rk}$) :: rea(n,n),ima(n,n)
#:endif
type(linalg_state_type) :: state
#:if 'complex' in rt
call random_number(rea)
call random_number(ima)
a = cmplx(rea,ima,kind=${rk}$)
#:else
call random_number(a)
#:endif
! Test simple API
call schur(a,t,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Test output transformation matrix
call schur(a,t,z,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Test output eigenvalues
call schur(a,t,eigvals=eigs,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Test storage query
call schur_space(a,lwork,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Test with user-defined storage
allocate(storage(lwork))
call schur(a,t,eigvals=eigs,storage=storage,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
end subroutine test_schur_api_${ri}$
subroutine test_schur_random_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: n = 3_ilp
real(${rk}$), parameter :: rtol = 1.0e-4_${rk}$
real(${rk}$), parameter :: eps = sqrt(epsilon(0.0_${rk}$))
integer(ilp) :: lwork
${rt}$, allocatable :: storage(:)
${rt}$, dimension(n,n) :: a,t,z,aorig
#:if 'complex' in rt
real(${rk}$), dimension(n,n) :: a_re,a_im
#:endif
type(linalg_state_type) :: state
#:if 'complex' in rt
call random_number(a_re)
call random_number(a_im)
a = cmplx(a_re,a_im,kind=${rk}$)
#:else
call random_number(a)
#:endif
aorig = a
! 1) Run schur (standard)
call schur(a,t,z,err=state)
! Check return code
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Check solution
call check(error, all(schur_error(a,z,t)<=max(rtol*abs(a),eps)), &
'converged solution (${rt}$)')
if (allocated(error)) return
! 2) Run schur (overwrite A)
call schur(a,t,z,overwrite_a=.true.,err=state)
! Check return code
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Check solution
call check(error, all(schur_error(aorig,z,t)<=max(rtol*abs(aorig),eps)), &
'converged solution (${rt}$ - overwrite A)')
if (allocated(error)) return
! 3) Use working storage
a = aorig
call schur_space(a,lwork,err=state)
! Check return code
call check(error,state%ok(),state%print())
if (allocated(error)) return
allocate(storage(lwork))
call schur(a,t,z,storage=storage,err=state)
! Check return code
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Check solution
call check(error, all(schur_error(a,z,t)<=max(rtol*abs(a),eps)), &
'converged solution (${rt}$ - external storage)')
if (allocated(error)) return
contains
pure function schur_error(a,z,t) result(err)
${rt}$, intent(in), dimension(:,:) :: a,z,t
real(${rk}$), dimension(size(a,1),size(a,2)) :: err
#:if rt.startswith('real')
err = abs(matmul(matmul(z,t),transpose(z)) - a)
#:else
err = abs(matmul(matmul(z,t),conjg(transpose(z))) - a)
#:endif
end function schur_error
end subroutine test_schur_random_${ri}$
!> Test symmetric matrix (real eigenvalues)
subroutine test_schur_symmetric_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: n = 3_ilp
real(${rk}$), parameter :: rtol = 1.0e-4_${rk}$
real(${rk}$), parameter :: eps = sqrt(epsilon(0.0_${rk}$))
real(${rk}$) :: reigs(n)
${rt}$, dimension(n,n) :: a, t, z
type(linalg_state_type) :: state
! Define a symmetric 3x3 matrix with real eigenvalues
a = reshape([ 3, 1, 0, &
1, 3, 1, &
0, 1, 3], shape=[n, n])
! Return real eigenvalues (Should trigger an error if they have an imaginary part)
call schur(a, t, z, eigvals=reigs, err=state)
! Check return code
call check(error, state%ok(), state%print())
if (allocated(error)) return
! Check solution
call check(error, all(schur_error(a, z, t) <= max(rtol * abs(a), eps)), &
'converged solution (real symmetric, real eigs)')
if (allocated(error)) return
contains
pure function schur_error(a,z,t) result(err)
${rt}$, intent(in), dimension(:,:) :: a,z,t
real(${rk}$), dimension(size(a,1),size(a,2)) :: err
#:if rt.startswith('real')
err = abs(matmul(matmul(z,t),transpose(z)) - a)
#:else
err = abs(matmul(matmul(z,t),conjg(transpose(z))) - a)
#:endif
end function schur_error
end subroutine test_schur_symmetric_${ri}$
#:endfor
! gcc-15 bugfix utility
subroutine add_test(tests,new_test)
type(unittest_type), allocatable, intent(inout) :: tests(:)
type(unittest_type), intent(in) :: new_test
integer :: n
type(unittest_type), allocatable :: new_tests(:)
if (allocated(tests)) then
n = size(tests)
else
n = 0
end if
allocate(new_tests(n+1))
if (n>0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_schur
program test_schur
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_schur, only : test_schur_decomposition
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_schur", test_schur_decomposition) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_schur
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_specialmatrices.fypp 0000664 0001750 0001750 00000014172 15135654166 027055 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES
module test_specialmatrices
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_kinds
use stdlib_linalg, only: hermitian
use stdlib_linalg_state, only: linalg_state_type
use stdlib_math, only: all_close
use stdlib_specialmatrices
implicit none
contains
!> Collect all exported unit tests
subroutine collect_suite(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('tridiagonal', test_tridiagonal), &
new_unittest('tridiagonal error handling', test_tridiagonal_error_handling) &
]
end subroutine
subroutine test_tridiagonal(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
integer, parameter :: n = 5
type(tridiagonal_${s1}$_type) :: A
${t1}$, allocatable :: Amat(:,:), dl(:), dv(:), du(:)
${t1}$, allocatable :: x(:)
${t1}$, allocatable :: y1(:), y2(:)
${t1}$ :: alpha, beta
integer :: i, j
${t1}$, parameter :: coeffs(3) = [-1.0_wp, 0.0_wp, 1.0_wp]
! Initialize matrix.
allocate(dl(n-1), dv(n), du(n-1))
call random_number(dl) ; call random_number(dv) ; call random_number(du)
A = tridiagonal(dl, dv, du) ; Amat = dense(A)
! Random vectors.
allocate(x(n), source = 0.0_wp) ; call random_number(x)
allocate(y1(n), source = 0.0_wp) ; allocate(y2(n), source=0.0_wp)
! Test y = A @ x
y1 = matmul(Amat, x) ; call spmv(A, x, y2)
call check(error, all_close(y1, y2), .true.)
if (allocated(error)) return
! Test y = A.T @ x
y1 = 0.0_wp ; y2 = 0.0_wp
y1 = matmul(transpose(Amat), x) ; call spmv(A, x, y2, op="T")
call check(error, all_close(y1, y2), .true.)
if (allocated(error)) return
#:if t1.startswith('complex')
! Test y = A.H @ x
y1 = 0.0_wp ; y2 = 0.0_wp
y1 = matmul(hermitian(Amat), x) ; call spmv(A, x, y2, op="H")
call check(error, all_close(y1, y2), .true.)
if (allocated(error)) return
#:endif
! Test y = alpha * A @ x + beta * y for alpha,beta in {-1,0,1}
do i = 1, 3
do j = 1,3
alpha = coeffs(i)
beta = coeffs(j)
y1 = 0.0_wp
call random_number(y2)
y1 = alpha * matmul(Amat, x) + beta * y2
call spmv(A, x, y2, alpha=alpha, beta=beta)
call check(error, all_close(y1, y2), .true.)
if (allocated(error)) return
end do
end do
! Test y = A @ x for random values of alpha and beta
y1 = 0.0_wp
call random_number(alpha)
call random_number(beta)
call random_number(y2)
y1 = alpha * matmul(Amat, x) + beta * y2
call spmv(A, x, y2, alpha=alpha, beta=beta)
call check(error, all_close(y1, y2), .true.)
if (allocated(error)) return
! Test y = A.T @ x for random values of alpha and beta
y1 = 0.0_wp
call random_number(alpha)
call random_number(beta)
call random_number(y2)
y1 = alpha * matmul(transpose(Amat), x) + beta * y2
call spmv(A, x, y2, alpha=alpha, beta=beta, op="T")
call check(error, all_close(y1, y2), .true.)
if (allocated(error)) return
#:if t1.startswith('complex')
! Test y = A.H @ x for random values of alpha and beta
y1 = 0.0_wp
call random_number(alpha)
call random_number(beta)
call random_number(y2)
y1 = alpha * matmul(transpose(conjg((Amat))), x) + beta * y2
call spmv(A, x, y2, alpha=alpha, beta=beta, op="H")
call check(error, all_close(y1, y2), .true.)
if (allocated(error)) return
#:endif
end block
#:endfor
end subroutine
subroutine test_tridiagonal_error_handling(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
integer, parameter :: n = 5
type(tridiagonal_${s1}$_type) :: A
${t1}$, allocatable :: dl(:), dv(:), du(:)
type(linalg_state_type) :: state
integer :: i
!> Test constructor from arrays.
dl = [(1.0_wp, i = 1, n-2)] ; du = dl
dv = [(2.0_wp, i = 1, n)]
A = tridiagonal(dl, dv, du, state)
call check(error, state%ok(), .false.)
if (allocated(error)) return
!> Test contructor from constants.
A = tridiagonal(dl(1), dv(1), du(1), -n, state)
call check(error, state%ok(), .false.)
if (allocated(error)) return
end block
#:endfor
end subroutine
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_specialmatrices, only : collect_suite
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("sparse", collect_suite) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_matrix_property_checks.fypp 0000664 0001750 0001750 00000061122 15135654166 030472 0 ustar alastair alastair #:include "common.fypp"
#:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES
module test_linalg_matrix_property_checks
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64
use stdlib_linalg, only: is_square ,is_diagonal, is_symmetric, &
is_skew_symmetric, is_hermitian, is_triangular, is_hessenberg
implicit none
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
#:if WITH_QP
real(qp), parameter :: qptol = 1000 * epsilon(1._qp)
#:endif
#! create new list that contains test subroutine suffix (rsp, cdp, int64, etc.)
#! alongside kind and type
#:set RCI_KINDS_TYPES_SUFFIXES = []
#:for k1, t1 in RCI_KINDS_TYPES
#:if t1[0] == 'i'
#:set SUFFIX_START = ''
#:else
#:set SUFFIX_START = t1[0]
#:endif
$:RCI_KINDS_TYPES_SUFFIXES.append((k1,t1,SUFFIX_START+k1))
#:endfor
contains
!> Collect all exported unit tests
subroutine collect_linalg_matrix_property_checks(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
#:set IMPLEMENTED_TESTS = ['is_square','is_diagonal','is_symmetric','is_skew_symmetric', &
'is_hermitian', 'is_triangular', 'is_hessenberg']
#:set NUM_TESTS = int(len(IMPLEMENTED_TESTS)*len(RCI_KINDS_TYPES_SUFFIXES))
#! set testsuite dynamically
testsuite = [ &
#:set TESTS_WRITTEN = 0
#:for cur_test in IMPLEMENTED_TESTS
#:for k1, t1, s1 in RCI_KINDS_TYPES_SUFFIXES
#! note that one has to use set directives to increment variable
#:set TESTS_WRITTEN = TESTS_WRITTEN + 1
#! last test in list should not have comma
#:if TESTS_WRITTEN < NUM_TESTS
new_unittest("${cur_test}$_${s1}$", test_${cur_test}$_${s1}$), &
#:else
new_unittest("${cur_test}$_${s1}$", test_${cur_test}$_${s1}$) &
#:endif
#:endfor
#:endfor
]
end subroutine collect_linalg_matrix_property_checks
!is_square
#:for k1, t1, s1 in RCI_KINDS_TYPES_SUFFIXES
subroutine test_is_square_${s1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#! variable sizes independent of type/kind
${t1}$ :: A_true(2,2), A_false(2,3)
#! populate variables dependent on type/kind
#:if s1[0] == 'r'
A_true = reshape([1.,2.,3.,4.],[2,2])
A_false = reshape([1.,2.,3.,4.,5.,6.],[2,3])
#:elif s1[0] == 'c'
A_true = reshape([cmplx(1.,0.),cmplx(2.,1.),cmplx(3.,0.),cmplx(4.,1.)],[2,2])
A_false = reshape([cmplx(1.,0.),cmplx(2.,1.),cmplx(3.,0.), &
cmplx(4.,1.),cmplx(5.,0.),cmplx(6.,1.)],[2,3])
#:elif s1[0] == 'i'
A_true = reshape([1,2,3,4],[2,2])
A_false = reshape([1,2,3,4,5,6],[2,3])
#:endif
#! error check calls are type/kind independent
call check(error, is_square(A_true), &
"is_square(A_true) failed.")
if (allocated(error)) return
call check(error, (.not. is_square(A_false)), &
"(.not. is_square(A_false)) failed.")
if (allocated(error)) return
end subroutine test_is_square_${s1}$
#:endfor
!is_diagonal
#:for k1, t1, s1 in RCI_KINDS_TYPES_SUFFIXES
subroutine test_is_diagonal_${s1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#! variable sizes independent of type/kind
${t1}$ :: A_true_s(2,2), A_false_s(2,2) !square matrices
${t1}$ :: A_true_sf(2,3), A_false_sf(2,3) !short and fat matrices
${t1}$ :: A_true_ts(3,2), A_false_ts(3,2) !tall and skinny matrices
#! populate variables dependent on type/kind
#:if s1[0] == 'r'
A_true_s = reshape([1.,0.,0.,4.],[2,2])
A_false_s = reshape([1.,0.,3.,4.],[2,2])
A_true_sf = reshape([1.,0.,0.,4.,0.,0.],[2,3])
A_false_sf = reshape([1.,0.,3.,4.,0.,0.],[2,3])
A_true_ts = reshape([1.,0.,0.,0.,5.,0.],[3,2])
A_false_ts = reshape([1.,0.,0.,0.,5.,6.],[3,2])
#:elif s1[0] == 'c'
A_true_s = reshape([cmplx(1.,1.),cmplx(0.,0.), &
cmplx(0.,0.),cmplx(4.,1.)],[2,2])
A_false_s = reshape([cmplx(1.,1.),cmplx(0.,0.), &
cmplx(3.,1.),cmplx(4.,1.)],[2,2])
A_true_sf = reshape([cmplx(1.,1.),cmplx(0.,0.), &
cmplx(0.,0.),cmplx(4.,1.), &
cmplx(0.,0.),cmplx(0.,0.)],[2,3])
A_false_sf = reshape([cmplx(1.,1.),cmplx(0.,0.), &
cmplx(3.,1.),cmplx(4.,1.), &
cmplx(0.,0.),cmplx(0.,0.)],[2,3])
A_true_ts = reshape([cmplx(1.,1.),cmplx(0.,0.),cmplx(0.,0.), &
cmplx(0.,0.),cmplx(5.,1.),cmplx(0.,0.)],[3,2])
A_false_ts = reshape([cmplx(1.,1.),cmplx(0.,0.),cmplx(0.,0.), &
cmplx(0.,0.),cmplx(5.,1.),cmplx(6.,1.)],[3,2])
#:elif s1[0] == 'i'
A_true_s = reshape([1,0,0,4],[2,2])
A_false_s = reshape([1,0,3,4],[2,2])
A_true_sf = reshape([1,0,0,4,0,0],[2,3])
A_false_sf = reshape([1,0,3,4,0,0],[2,3])
A_true_ts = reshape([1,0,0,0,5,0],[3,2])
A_false_ts = reshape([1,0,0,0,5,6],[3,2])
#:endif
#! error check calls are type/kind independent
call check(error, is_diagonal(A_true_s), &
"is_diagonal(A_true_s) failed.")
if (allocated(error)) return
call check(error, (.not. is_diagonal(A_false_s)), &
"(.not. is_diagonal(A_false_s)) failed.")
if (allocated(error)) return
call check(error, is_diagonal(A_true_sf), &
"is_diagonal(A_true_sf) failed.")
if (allocated(error)) return
call check(error, (.not. is_diagonal(A_false_sf)), &
"(.not. is_diagonal(A_false_sf)) failed.")
if (allocated(error)) return
call check(error, is_diagonal(A_true_ts), &
"is_diagonal(A_true_ts) failed.")
if (allocated(error)) return
call check(error, (.not. is_diagonal(A_false_ts)), &
"(.not. is_diagonal(A_false_ts)) failed.")
if (allocated(error)) return
end subroutine test_is_diagonal_${s1}$
#:endfor
!is_symmetric
#:for k1, t1, s1 in RCI_KINDS_TYPES_SUFFIXES
subroutine test_is_symmetric_${s1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#! variable sizes independent of type/kind
${t1}$ :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
#! populate variables dependent on type/kind
#:if s1[0] == 'r'
A_true = reshape([1.,2.,2.,4.],[2,2])
A_false_1 = reshape([1.,2.,3.,4.],[2,2])
A_false_2 = reshape([1.,2.,3.,2.,5.,6.],[3,2]) !nonsquare matrix
#:elif s1[0] == 'c'
A_true = reshape([cmplx(1.,1.),cmplx(2.,1.), &
cmplx(2.,1.),cmplx(4.,1.)],[2,2])
A_false_1 = reshape([cmplx(1.,1.),cmplx(2.,1.), &
cmplx(3.,1.),cmplx(4.,1.)],[2,2])
A_false_2 = reshape([cmplx(1.,1.),cmplx(2.,1.),cmplx(3.,1.), &
cmplx(2.,1.),cmplx(5.,1.),cmplx(6.,2.)],[3,2]) !nonsquare matrix
#:elif s1[0] == 'i'
A_true = reshape([1,2,2,4],[2,2])
A_false_1 = reshape([1,2,3,4],[2,2])
A_false_2 = reshape([1,2,3,2,5,6],[3,2]) !nonsquare matrix
#:endif
#! error check calls are type/kind independent
call check(error, is_symmetric(A_true), &
"is_symmetric(A_true) failed.")
if (allocated(error)) return
call check(error, (.not. is_symmetric(A_false_1)), &
"(.not. is_symmetric(A_false_1)) failed.")
if (allocated(error)) return
call check(error, (.not. is_symmetric(A_false_2)), &
"(.not. is_symmetric(A_false_2)) failed.")
if (allocated(error)) return
end subroutine test_is_symmetric_${s1}$
#:endfor
!is_skew_symmetric
#:for k1, t1, s1 in RCI_KINDS_TYPES_SUFFIXES
subroutine test_is_skew_symmetric_${s1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#! variable sizes independent of type/kind
${t1}$ :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
#! populate variables dependent on type/kind
#:if s1[0] == 'r'
A_true = reshape([0.,2.,-2.,0.],[2,2])
A_false_1 = reshape([0.,2.,-3.,0.],[2,2])
A_false_2 = reshape([0.,2.,3.,-2.,0.,6.],[3,2]) !nonsquare matrix
#:elif s1[0] == 'c'
A_true = reshape([cmplx(0.,0.),cmplx(2.,1.), &
-cmplx(2.,1.),cmplx(0.,0.)],[2,2])
A_false_1 = reshape([cmplx(0.,0.),cmplx(2.,1.), &
-cmplx(3.,1.),cmplx(0.,0.)],[2,2])
A_false_2 = reshape([cmplx(0.,0.),cmplx(2.,1.),cmplx(3.,0.), &
-cmplx(2.,1.),cmplx(0.,0.),cmplx(6.,0.)],[3,2]) !nonsquare matrix
#:elif s1[0] == 'i'
A_true = reshape([0,2,-2,0],[2,2])
A_false_1 = reshape([0,2,-3,0],[2,2])
A_false_2 = reshape([0,2,3,-2,0,6],[3,2]) !nonsquare matrix
#:endif
#! error check calls are type/kind independent
call check(error, is_skew_symmetric(A_true), &
"is_skew_symmetric(A_true) failed.")
if (allocated(error)) return
call check(error, (.not. is_skew_symmetric(A_false_1)), &
"(.not. is_skew_symmetric(A_false_1)) failed.")
if (allocated(error)) return
call check(error, (.not. is_skew_symmetric(A_false_2)), &
"(.not. is_skew_symmetric(A_false_2)) failed.")
if (allocated(error)) return
end subroutine test_is_skew_symmetric_${s1}$
#:endfor
!is_hermitian
#:for k1, t1, s1 in RCI_KINDS_TYPES_SUFFIXES
subroutine test_is_hermitian_${s1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#! variable sizes independent of type/kind
${t1}$ :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
#! populate variables dependent on type/kind
#:if s1[0] == 'r'
A_true = reshape([1.,2.,2.,4.],[2,2])
A_false_1 = reshape([1.,2.,3.,4.],[2,2])
A_false_2 = reshape([1.,2.,3.,2.,5.,6.],[3,2]) !nonsquare matrix
#:elif s1[0] == 'c'
A_true = reshape([cmplx(1.,0.),cmplx(2.,-1.), &
cmplx(2.,1.),cmplx(4.,0.)],[2,2])
A_false_1 = reshape([cmplx(1.,0.),cmplx(2.,-1.), &
cmplx(3.,1.),cmplx(4.,0.)],[2,2])
A_false_2 = reshape([cmplx(1.,0.),cmplx(2.,-1.),cmplx(3.,-1.), &
cmplx(2.,1.),cmplx(5.,0.),cmplx(6.,-1.)],[3,2]) !nonsquare matrix
#:elif s1[0] == 'i'
A_true = reshape([1,2,2,4],[2,2])
A_false_1 = reshape([1,2,3,4],[2,2])
A_false_2 = reshape([1,2,3,2,5,6],[3,2]) !nonsquare matrix
#:endif
#! error check calls are type/kind independent
call check(error, is_hermitian(A_true), &
"is_hermitian(A_true) failed.")
if (allocated(error)) return
call check(error, (.not. is_hermitian(A_false_1)), &
"(.not. is_hermitian(A_false_1)) failed.")
if (allocated(error)) return
call check(error, (.not. is_hermitian(A_false_2)), &
"(.not. is_hermitian(A_false_2)) failed.")
if (allocated(error)) return
end subroutine test_is_hermitian_${s1}$
#:endfor
!is_triangular
#:for k1, t1, s1 in RCI_KINDS_TYPES_SUFFIXES
subroutine test_is_triangular_${s1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#! variable sizes independent of type/kind
${t1}$ :: A_true_s_u(2,2), A_false_s_u(2,2) !square matrices (upper triangular)
${t1}$ :: A_true_sf_u(2,3), A_false_sf_u(2,3) !short and fat matrices
${t1}$ :: A_true_ts_u(3,2), A_false_ts_u(3,2) !tall and skinny matrices
${t1}$ :: A_true_s_l(2,2), A_false_s_l(2,2) !square matrices (lower triangular)
${t1}$ :: A_true_sf_l(2,3), A_false_sf_l(2,3) !short and fat matrices
${t1}$ :: A_true_ts_l(3,2), A_false_ts_l(3,2) !tall and skinny matrices
#! populate variables dependent on type/kind
#:if s1[0] == 'r'
!upper triangular
A_true_s_u = reshape([1.,0.,3.,4.],[2,2])
A_false_s_u = reshape([1.,2.,0.,4.],[2,2])
A_true_sf_u = reshape([1.,0.,3.,4.,0.,6.],[2,3])
A_false_sf_u = reshape([1.,2.,3.,4.,0.,6.],[2,3])
A_true_ts_u = reshape([1.,0.,0.,4.,5.,0.],[3,2])
A_false_ts_u = reshape([1.,0.,0.,4.,5.,6.],[3,2])
!lower triangular
A_true_s_l = reshape([1.,2.,0.,4.],[2,2])
A_false_s_l = reshape([1.,0.,3.,4.],[2,2])
A_true_sf_l = reshape([1.,2.,0.,4.,0.,0.],[2,3])
A_false_sf_l = reshape([1.,2.,3.,4.,0.,0.],[2,3])
A_true_ts_l = reshape([1.,2.,3.,0.,5.,6.],[3,2])
A_false_ts_l = reshape([1.,2.,3.,4.,5.,6.],[3,2])
#:elif s1[0] == 'c'
!upper triangular
A_true_s_u = reshape([cmplx(1.,1.),cmplx(0.,0.), &
cmplx(3.,1.),cmplx(4.,0.)],[2,2])
A_false_s_u = reshape([cmplx(1.,1.),cmplx(2.,0.), &
cmplx(0.,0.),cmplx(4.,0.)],[2,2])
A_true_sf_u = reshape([cmplx(1.,1.),cmplx(0.,0.), &
cmplx(3.,1.),cmplx(4.,0.), &
cmplx(0.,0.),cmplx(6.,0.)],[2,3])
A_false_sf_u = reshape([cmplx(1.,1.),cmplx(2.,0.), &
cmplx(3.,1.),cmplx(4.,0.), &
cmplx(0.,0.),cmplx(6.,0.)],[2,3])
A_true_ts_u = reshape([cmplx(1.,1.),cmplx(0.,0.),cmplx(0.,0.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(0.,0.)],[3,2])
A_false_ts_u = reshape([cmplx(1.,1.),cmplx(0.,0.),cmplx(0.,0.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.)],[3,2])
!lower triangular
A_true_s_l = reshape([cmplx(1.,1.),cmplx(2.,0.), &
cmplx(0.,0.),cmplx(4.,0.)],[2,2])
A_false_s_l = reshape([cmplx(1.,1.),cmplx(0.,0.), &
cmplx(3.,1.),cmplx(4.,0.)],[2,2])
A_true_sf_l = reshape([cmplx(1.,1.),cmplx(2.,0.), &
cmplx(0.,0.),cmplx(4.,0.), &
cmplx(0.,0.),cmplx(0.,0.)],[2,3])
A_false_sf_l = reshape([cmplx(1.,1.),cmplx(2.,0.), &
cmplx(3.,1.),cmplx(4.,0.), &
cmplx(0.,0.),cmplx(0.,0.)],[2,3])
A_true_ts_l = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.), &
cmplx(0.,0.),cmplx(5.,1.),cmplx(6.,0.)],[3,2])
A_false_ts_l = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.)],[3,2])
#:elif s1[0] == 'i'
!upper triangular
A_true_s_u = reshape([1,0,3,4],[2,2])
A_false_s_u = reshape([1,2,0,4],[2,2])
A_true_sf_u = reshape([1,0,3,4,0,6],[2,3])
A_false_sf_u = reshape([1,2,3,4,0,6],[2,3])
A_true_ts_u = reshape([1,0,0,4,5,0],[3,2])
A_false_ts_u = reshape([1,0,0,4,5,6],[3,2])
!lower triangular
A_true_s_l = reshape([1,2,0,4],[2,2])
A_false_s_l = reshape([1,0,3,4],[2,2])
A_true_sf_l = reshape([1,2,0,4,0,0],[2,3])
A_false_sf_l = reshape([1,2,3,4,0,0],[2,3])
A_true_ts_l = reshape([1,2,3,0,5,6],[3,2])
A_false_ts_l = reshape([1,2,3,4,5,6],[3,2])
#:endif
#! error check calls are type/kind independent
!upper triangular checks
call check(error, is_triangular(A_true_s_u,'u'), &
"is_triangular(A_true_s_u,'u') failed.")
if (allocated(error)) return
call check(error, (.not. is_triangular(A_false_s_u,'u')), &
"(.not. is_triangular(A_false_s_u,'u')) failed.")
if (allocated(error)) return
call check(error, is_triangular(A_true_sf_u,'u'), &
"is_triangular(A_true_sf_u,'u') failed.")
if (allocated(error)) return
call check(error, (.not. is_triangular(A_false_sf_u,'u')), &
"(.not. is_triangular(A_false_sf_u,'u')) failed.")
if (allocated(error)) return
call check(error, is_triangular(A_true_ts_u,'u'), &
"is_triangular(A_true_ts_u,'u') failed.")
if (allocated(error)) return
call check(error, (.not. is_triangular(A_false_ts_u,'u')), &
"(.not. is_triangular(A_false_ts_u,'u')) failed.")
if (allocated(error)) return
!lower triangular checks
call check(error, is_triangular(A_true_s_l,'l'), &
"is_triangular(A_true_s_l,'l') failed.")
if (allocated(error)) return
call check(error, (.not. is_triangular(A_false_s_l,'l')), &
"(.not. is_triangular(A_false_s_l,'l')) failed.")
if (allocated(error)) return
call check(error, is_triangular(A_true_sf_l,'l'), &
"is_triangular(A_true_sf_l,'l') failed.")
if (allocated(error)) return
call check(error, (.not. is_triangular(A_false_sf_l,'l')), &
"(.not. is_triangular(A_false_sf_l,'l')) failed.")
if (allocated(error)) return
call check(error, is_triangular(A_true_ts_l,'l'), &
"is_triangular(A_true_ts_l,'l') failed.")
if (allocated(error)) return
call check(error, (.not. is_triangular(A_false_ts_l,'l')), &
"(.not. is_triangular(A_false_ts_l,'l')) failed.")
if (allocated(error)) return
end subroutine test_is_triangular_${s1}$
#:endfor
!is_hessenberg
#:for k1, t1, s1 in RCI_KINDS_TYPES_SUFFIXES
subroutine test_is_hessenberg_${s1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#! variable sizes independent of type/kind
${t1}$ :: A_true_s_u(3,3), A_false_s_u(3,3) !square matrices (upper hessenberg)
${t1}$ :: A_true_sf_u(3,4), A_false_sf_u(3,4) !short and fat matrices
${t1}$ :: A_true_ts_u(4,3), A_false_ts_u(4,3) !tall and skinny matrices
${t1}$ :: A_true_s_l(3,3), A_false_s_l(3,3) !square matrices (lower hessenberg)
${t1}$ :: A_true_sf_l(3,4), A_false_sf_l(3,4) !short and fat matrices
${t1}$ :: A_true_ts_l(4,3), A_false_ts_l(4,3) !tall and skinny matrices
#! populate variables dependent on type/kind
#:if s1[0] == 'r'
!upper hessenberg
A_true_s_u = reshape([1.,2.,0.,4.,5.,6.,7.,8.,9.],[3,3])
A_false_s_u = reshape([1.,2.,3.,4.,5.,6.,7.,8.,9.],[3,3])
A_true_sf_u = reshape([1.,2.,0.,4.,5.,6.,7.,8.,9.,10.,11.,12.],[3,4])
A_false_sf_u = reshape([1.,2.,3.,4.,5.,6.,7.,8.,9.,10.,11.,12.],[3,4])
A_true_ts_u = reshape([1.,2.,0.,0.,5.,6.,7.,0.,9.,10.,11.,12.],[4,3])
A_false_ts_u = reshape([1.,2.,3.,0.,5.,6.,7.,0.,9.,10.,11.,12.],[4,3])
!lower hessenberg
A_true_s_l = reshape([1.,2.,3.,4.,5.,6.,0.,8.,9.],[3,3])
A_false_s_l = reshape([1.,2.,3.,4.,5.,6.,7.,8.,9.],[3,3])
A_true_sf_l = reshape([1.,2.,3.,4.,5.,6.,0.,8.,9.,0.,0.,12.],[3,4])
A_false_sf_l = reshape([1.,2.,3.,4.,5.,6.,0.,8.,9.,0.,11.,12.],[3,4])
A_true_ts_l = reshape([1.,2.,3.,4.,5.,6.,7.,8.,0.,10.,11.,12.],[4,3])
A_false_ts_l = reshape([1.,2.,3.,4.,5.,6.,7.,8.,9.,10.,11.,12.],[4,3])
#:elif s1[0] == 'c'
!upper hessenberg
A_true_s_u = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(0.,0.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.), &
cmplx(7.,1.),cmplx(8.,0.),cmplx(9.,1.)],[3,3])
A_false_s_u = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.), &
cmplx(7.,1.),cmplx(8.,0.),cmplx(9.,1.)],[3,3])
A_true_sf_u = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(0.,0.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.), &
cmplx(7.,1.),cmplx(8.,0.),cmplx(9.,1.), &
cmplx(10.,0.),cmplx(11.,1.),cmplx(12.,0.)],[3,4])
A_false_sf_u = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.), &
cmplx(7.,1.),cmplx(8.,0.),cmplx(9.,1.), &
cmplx(10.,0.),cmplx(11.,1.),cmplx(12.,0.)],[3,4])
A_true_ts_u = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(0.,0.),cmplx(0.,0.), &
cmplx(5.,1.),cmplx(6.,0.),cmplx(7.,1.),cmplx(0.,0.), &
cmplx(9.,1.),cmplx(10.,0.),cmplx(11.,1.),cmplx(12.,0.)],[4,3])
A_false_ts_u = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.),cmplx(0.,0.), &
cmplx(5.,1.),cmplx(6.,0.),cmplx(7.,1.),cmplx(0.,0.), &
cmplx(9.,1.),cmplx(10.,0.),cmplx(11.,1.),cmplx(12.,0.)],[4,3])
!lower hessenberg
A_true_s_l = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.), &
cmplx(0.,0.),cmplx(8.,0.),cmplx(9.,1.)],[3,3])
A_false_s_l = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.), &
cmplx(7.,1.),cmplx(8.,0.),cmplx(9.,1.)],[3,3])
A_true_sf_l = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.), &
cmplx(0.,0.),cmplx(8.,0.),cmplx(9.,1.), &
cmplx(0.,0.),cmplx(0.,0.),cmplx(12.,0.)],[3,4])
A_false_sf_l = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.), &
cmplx(4.,0.),cmplx(5.,1.),cmplx(6.,0.), &
cmplx(0.,0.),cmplx(8.,0.),cmplx(9.,1.), &
cmplx(0.,0.),cmplx(11.,1.),cmplx(12.,0.)],[3,4])
A_true_ts_l = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.),cmplx(4.,0.), &
cmplx(5.,1.),cmplx(6.,0.),cmplx(7.,1.),cmplx(8.,0.), &
cmplx(0.,0.),cmplx(10.,0.),cmplx(11.,1.),cmplx(12.,0.)],[4,3])
A_false_ts_l = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(3.,1.),cmplx(4.,0.), &
cmplx(5.,1.),cmplx(6.,0.),cmplx(7.,1.),cmplx(8.,0.), &
cmplx(9.,1.),cmplx(10.,0.),cmplx(11.,1.),cmplx(12.,0.)],[4,3])
#:elif s1[0] == 'i'
!upper hessenberg
A_true_s_u = reshape([1,2,0,4,5,6,7,8,9],[3,3])
A_false_s_u = reshape([1,2,3,4,5,6,7,8,9],[3,3])
A_true_sf_u = reshape([1,2,0,4,5,6,7,8,9,10,11,12],[3,4])
A_false_sf_u = reshape([1,2,3,4,5,6,7,8,9,10,11,12],[3,4])
A_true_ts_u = reshape([1,2,0,0,5,6,7,0,9,10,11,12],[4,3])
A_false_ts_u = reshape([1,2,3,0,5,6,7,0,9,10,11,12],[4,3])
!lower hessenberg
A_true_s_l = reshape([1,2,3,4,5,6,0,8,9],[3,3])
A_false_s_l = reshape([1,2,3,4,5,6,7,8,9],[3,3])
A_true_sf_l = reshape([1,2,3,4,5,6,0,8,9,0,0,12],[3,4])
A_false_sf_l = reshape([1,2,3,4,5,6,0,8,9,0,11,12],[3,4])
A_true_ts_l = reshape([1,2,3,4,5,6,7,8,0,10,11,12],[4,3])
A_false_ts_l = reshape([1,2,3,4,5,6,7,8,9,10,11,12],[4,3])
#:endif
#! error check calls are type/kind independent
!upper hessenberg checks
call check(error, is_hessenberg(A_true_s_u,'u'), &
"is_hessenberg(A_true_s_u,'u') failed.")
call check(error, (.not. is_hessenberg(A_false_s_u,'u')), &
"(.not. is_hessenberg(A_false_s_u,'u')) failed.")
call check(error, is_hessenberg(A_true_sf_u,'u'), &
"is_hessenberg(A_true_sf_u,'u') failed.")
call check(error, (.not. is_hessenberg(A_false_sf_u,'u')), &
"(.not. is_hessenberg(A_false_sf_u,'u')) failed.")
call check(error, is_hessenberg(A_true_ts_u,'u'), &
"is_hessenberg(A_true_ts_u,'u') failed.")
call check(error, (.not. is_hessenberg(A_false_ts_u,'u')), &
"(.not. is_hessenberg(A_false_ts_u,'u')) failed.")
!lower hessenberg checks
call check(error, is_hessenberg(A_true_s_l,'l'), &
"is_hessenberg(A_true_s_l,'l') failed.")
call check(error, (.not. is_hessenberg(A_false_s_l,'l')), &
"(.not. is_hessenberg(A_false_s_l,'l')) failed.")
call check(error, is_hessenberg(A_true_sf_l,'l'), &
"is_hessenberg(A_true_sf_l,'l') failed.")
call check(error, (.not. is_hessenberg(A_false_sf_l,'l')), &
"(.not. is_hessenberg(A_false_sf_l,'l')) failed.")
call check(error, is_hessenberg(A_true_ts_l,'l'), &
"is_hessenberg(A_true_ts_l,'l') failed.")
call check(error, (.not. is_hessenberg(A_false_ts_l,'l')), &
"(.not. is_hessenberg(A_false_ts_l,'l')) failed.")
end subroutine test_is_hessenberg_${s1}$
#:endfor
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_matrix_property_checks, only : collect_linalg_matrix_property_checks
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_matrix_property_checks", collect_linalg_matrix_property_checks) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_sparse.fypp 0000664 0001750 0001750 00000033557 15135654166 025212 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES
module test_sparse_spmv
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64
use stdlib_sparse
implicit none
contains
!> Collect all exported unit tests
subroutine collect_suite(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('coo', test_coo), &
new_unittest('coo2ordered', test_coo2ordered), &
new_unittest('csr', test_csr), &
new_unittest('csc', test_csc), &
new_unittest('ell', test_ell), &
new_unittest('sellc', test_sellc), &
new_unittest('symmetries', test_symmetries), &
new_unittest('diagonal', test_diagonal), &
new_unittest('add_get_values', test_add_get_values) &
]
end subroutine
subroutine test_coo(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
type(COO_${s1}$_type) :: COO
${t1}$, allocatable :: dense(:,:)
${t1}$, allocatable :: vec_x(:)
${t1}$, allocatable :: vec_y1(:), vec_y2(:)
allocate( dense(4,5) , source = &
reshape(real([9,4, 0,4, &
0,7, 8,0, &
0,0,-1,5, &
0,0, 8,6, &
-3,0, 0,0],kind=wp),[4,5]) )
call dense2coo( dense , COO )
allocate( vec_x(5) , source = 1._wp )
allocate( vec_y1(4) , source = 0._wp )
allocate( vec_y2(4) , source = 0._wp )
vec_y1 = matmul( dense, vec_x )
call check(error, all(vec_y1 == real([6,11,15,15],kind=wp)) )
if (allocated(error)) return
call spmv( COO, vec_x, vec_y2 )
call check(error, all(vec_y1 == vec_y2) )
if (allocated(error)) return
! Test in-place transpose
vec_y1 = 1._wp
call spmv( COO, vec_y1, vec_x, op=sparse_op_transpose )
call check(error, all(vec_x == real([17,15,4,14,-3],kind=wp)) )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_coo2ordered(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(COO_sp_type) :: COO
integer :: row(12), col(12)
real :: data(12)
row = [1,1,1,2,2,3,2,2,2,3,3,4]
col = [2,3,4,3,4,4,3,4,5,4,5,5]
data = 1.0
call from_ijv(COO,row,col,data)
call coo2ordered(COO,sort_data=.true.)
call check(error, COO%nnz < 12 .and. COO%nnz == 9 )
if (allocated(error)) return
call check(error, all(COO%data==[1,1,1,2,2,1,2,1,1]) )
if (allocated(error)) return
call check(error, all(COO%index(1,:)==[1,1,1,2,2,2,3,3,4]) )
if (allocated(error)) return
call check(error, all(COO%index(2,:)==[2,3,4,3,4,5,4,5,5]) )
if (allocated(error)) return
end subroutine
subroutine test_csr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
type(CSR_${s1}$_type) :: CSR
${t1}$, allocatable :: vec_x(:)
${t1}$, allocatable :: vec_y(:)
call CSR%malloc(4,5,10)
CSR%data(:) = real([9,-3,4,7,8,-1,8,4,5,6],kind=wp)
CSR%col(:) = [1,5,1,2,2,3,4,1,3,4]
CSR%rowptr(:) = [1,3,5,8,11]
allocate( vec_x(5) , source = 1._wp )
allocate( vec_y(4) , source = 0._wp )
call spmv( CSR, vec_x, vec_y )
call check(error, all(vec_y == real([6,11,15,15],kind=wp)) )
if (allocated(error)) return
! Test in-place transpose
vec_y = 1._wp
call spmv( CSR, vec_y, vec_x, op=sparse_op_transpose )
call check(error, all(vec_x == real([17,15,4,14,-3],kind=wp)) )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_csc(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
type(CSC_${s1}$_type) :: CSC
${t1}$, allocatable :: vec_x(:)
${t1}$, allocatable :: vec_y(:)
call CSC%malloc(4,5,10)
CSC%data(:) = real([9,4,4,7,8,-1,5,8,6,-3],kind=wp)
CSC%row(:) = [1,2,4,2,3,3,4,3,4,1]
CSC%colptr(:) = [1,4,6,8,10,11]
allocate( vec_x(5) , source = 1._wp )
allocate( vec_y(4) , source = 0._wp )
call spmv( CSC, vec_x, vec_y )
call check(error, all(vec_y == real([6,11,15,15],kind=wp)) )
if (allocated(error)) return
! Test in-place transpose
vec_y = 1._wp
call spmv( CSC, vec_y, vec_x, op=sparse_op_transpose )
call check(error, all(vec_x == real([17,15,4,14,-3],kind=wp)) )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_ell(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
type(ELL_${s1}$_type) :: ELL
${t1}$, allocatable :: vec_x(:)
${t1}$, allocatable :: vec_y(:)
call ELL%malloc(4,5,3)
ELL%data(1,1:3) = real([9,-3,0],kind=wp)
ELL%data(2,1:3) = real([4,7,0],kind=wp)
ELL%data(3,1:3) = real([8,-1,8],kind=wp)
ELL%data(4,1:3) = real([4,5,6],kind=wp)
ELL%index(1,1:3) = [1,5,0]
ELL%index(2,1:3) = [1,2,0]
ELL%index(3,1:3) = [2,3,4]
ELL%index(4,1:3) = [1,3,4]
allocate( vec_x(5) , source = 1._wp )
allocate( vec_y(4) , source = 0._wp )
call spmv( ELL, vec_x, vec_y )
call check(error, all(vec_y == real([6,11,15,15],kind=wp)) )
if (allocated(error)) return
! Test in-place transpose
vec_y = 1._wp
call spmv( ELL, vec_y, vec_x, op=sparse_op_transpose )
call check(error, all(vec_x == real([17,15,4,14,-3],kind=wp)) )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_sellc(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
type(SELLC_${s1}$_type) :: SELLC
type(CSR_${s1}$_type) :: CSR
${t1}$, allocatable :: vec_x(:)
${t1}$, allocatable :: vec_y(:), vec_y2(:)
integer :: i
call CSR%malloc(6,6,17)
! 1 2 3 4 5 6
CSR%col = [ 1, 3, 4, &
2, 3, 5, 6, &
1, 2, 3, &
5, 6, &
4, 5, &
2, 5, 6]
CSR%rowptr = [1,4,8,11,13,15,18]
CSR%data = [(real(i,kind=wp),i=1,CSR%nnz)]
call csr2sellc(CSR,SELLC,4)
allocate( vec_x(6) , source = 1._wp )
allocate( vec_y(6) , source = 0._wp )
call spmv( SELLC, vec_x, vec_y )
call check(error, all(vec_y == real([6,22,27,23,27,48],kind=wp)) )
if (allocated(error)) return
! Test in-place transpose
vec_x = real( [1,2,3,4,5,6] , kind=wp )
call spmv( CSR, vec_x, vec_y , op = sparse_op_transpose )
allocate( vec_y2(6) , source = 0._wp )
call spmv( SELLC, vec_x, vec_y2 , op = sparse_op_transpose )
call check(error, all(vec_y == vec_y2))
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_symmetries(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
type(COO_${s1}$_type) :: COO
type(CSR_${s1}$_type) :: CSR
type(ELL_${s1}$_type) :: ELL
${t1}$, allocatable :: dense(:,:)
${t1}$, allocatable :: vec_x(:)
${t1}$, allocatable :: vec_y1(:), vec_y2(:), vec_y3(:), vec_y4(:)
allocate( vec_x(4) , source = 1._wp )
allocate( vec_y1(4) , source = 0._wp )
allocate( vec_y2(4) , source = 0._wp )
allocate( vec_y3(4) , source = 0._wp )
allocate( vec_y4(4) , source = 0._wp )
allocate( dense(4,4) , source = &
reshape(real([1,0,0,0, &
2,1,0,0, &
0,2,1,0,&
0,0,2,1],kind=wp),[4,4]) )
call dense2coo( dense , COO )
COO%storage = sparse_upper
call coo2csr(COO, CSR)
call csr2ell(CSR, ELL)
dense(2,1) = 2._wp; dense(3,2) = 2._wp; dense(4,3) = 2._wp
vec_y1 = matmul( dense, vec_x )
call check(error, all(vec_y1 == [3,5,5,3]) )
if (allocated(error)) return
call spmv( COO , vec_x, vec_y2 )
call check(error, all(vec_y1 == vec_y2) )
if (allocated(error)) return
call spmv( CSR , vec_x, vec_y3 )
call check(error, all(vec_y1 == vec_y3) )
if (allocated(error)) return
call spmv( ELL , vec_x, vec_y4 )
call check(error, all(vec_y1 == vec_y4) )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_diagonal(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
${t1}$, allocatable :: dense(:,:)
type(COO_${s1}$_type) :: COO
type(CSR_${s1}$_type) :: CSR
type(CSC_${s1}$_type) :: CSC
${t1}$, allocatable :: diagonal(:)
allocate( dense(4,4) , source = &
reshape(real([1,0,0,5, &
0,2,0,0, &
0,6,3,0,&
0,0,7,4],kind=wp),[4,4]) )
call diag(dense,diagonal)
call check(error, all(diagonal == [1,2,3,4]) )
if (allocated(error)) return
diagonal = 0.0
call dense2coo( dense , COO )
call diag( COO , diagonal )
call check(error, all(diagonal == [1,2,3,4]) )
if (allocated(error)) return
diagonal = 0.0
call coo2csr( COO, CSR )
call diag( CSR , diagonal )
call check(error, all(diagonal == [1,2,3,4]) )
if (allocated(error)) return
diagonal = 0.0
call coo2csc( COO, CSC )
call diag( CSC , diagonal )
call check(error, all(diagonal == [1,2,3,4]) )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_add_get_values(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for k1, t1, s1 in (KINDS_TYPES)
block
integer, parameter :: wp = ${k1}$
real(wp) :: dense(5,5), mat(2,2)
type(COO_${s1}$_type) :: COO
type(CSR_${s1}$_type) :: CSR
${t1}$:: err
integer :: i, j, locdof(2)
mat(:,1) = [1,2]; mat(:,2) = [2,1]
dense = 0._wp
do i = 0, 3
dense(1+i:2+i,1+i:2+i) = dense(1+i:2+i,1+i:2+i) + mat
end do
call dense2coo(dense,COO)
call coo2csr(COO,CSR)
CSR%data = 0._wp
do i = 0, 3
locdof(1:2) = [1+i,2+i]
call CSR%add(locdof,locdof,mat)
end do
call check(error, all(CSR%data == COO%data) )
if (allocated(error)) return
err = 0._wp
do i = 1, 5
do j = 1, 5
err = err + abs(dense(i,j) - CSR%at(i,j))
end do
end do
err = err / 5*5
call check(error, err <= epsilon(0._wp) )
if (allocated(error)) return
end block
#:endfor
end subroutine
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_sparse_spmv, only : collect_suite
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("sparse", collect_suite) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_svd.fypp 0000664 0001750 0001750 00000027014 15135654166 024500 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test singular value decomposition
module test_linalg_svd
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg, only: diag,svd,svdvals
use stdlib_linalg_state, only: linalg_state_type
implicit none (type,external)
public :: test_svd
contains
!> Solve several SVD problems
subroutine test_svd(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in REAL_KINDS_TYPES
call add_test(tests,new_unittest("test_svd_${ri}$",test_svd_${ri}$))
#:endfor
#:for ck,ct,ci in CMPLX_KINDS_TYPES
call add_test(tests,new_unittest("test_complex_svd_${ci}$",test_complex_svd_${ci}$))
#:endfor
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("test_svd_row_${ri}$",test_svd_row_${ri}$))
#:endfor
end subroutine test_svd
!> Real matrix svd
#:for rk,rt,ri in REAL_KINDS_TYPES
subroutine test_svd_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
${rt}$, parameter :: tol = sqrt(epsilon(0.0_${rk}$))
${rt}$, parameter :: third = 1.0_${rk}$/3.0_${rk}$
${rt}$, parameter :: twothd = 2*third
${rt}$, parameter :: rsqrt2 = 1.0_${rk}$/sqrt(2.0_${rk}$)
${rt}$, parameter :: rsqrt18 = 1.0_${rk}$/sqrt(18.0_${rk}$)
${rt}$, parameter :: A_mat(2,3) = reshape([${rt}$ :: 3,2, 2,3, 2,-2],[2,3])
${rt}$, parameter :: s_sol(2) = [${rt}$ :: 5, 3]
${rt}$, parameter :: u_sol(2,2) = reshape(rsqrt2*[1,1,1,-1],[2,2])
${rt}$, parameter :: vt_sol(3,3) = reshape([rsqrt2,rsqrt18,twothd, &
rsqrt2,-rsqrt18,-twothd,&
0.0_${rk}$,4*rsqrt18,-third],[3,3])
!> Local variables
character(:), allocatable :: test
type(linalg_state_type) :: state
${rt}$ :: A(2,3),s(2),u(2,2),vt(3,3)
!> Initialize matrix
A = A_mat
!> Simple subroutine version
call svd(A,s,err=state)
test = 'subroutine version'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
!> Function interface
s = svdvals(A,err=state)
test = 'function interface'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
!> [S, U]. Singular vectors could be all flipped
call svd(A,s,u,err=state)
test = 'subroutine with singular vectors'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
call check(error, all(abs(abs(u)-abs(u_sol))<=tol), test//': U')
if (allocated(error)) return
!> [S, U]. Overwrite A matrix
call svd(A,s,u,overwrite_a=.true.,err=state)
test = 'subroutine, overwrite_a'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
call check(error, all(abs(abs(u)-abs(u_sol))<=tol), test//': U')
if (allocated(error)) return
!> [S, U, V^T]
A = A_mat
call svd(A,s,u,vt,overwrite_a=.true.,err=state)
test = '[S, U, V^T]'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
call check(error, all(abs(abs(u)-abs(u_sol))<=tol), test//': U')
if (allocated(error)) return
call check(error, all(abs(abs(vt)-abs(vt_sol))<=tol), test//': V^T')
if (allocated(error)) return
!> [S, V^T]. Do not overwrite A matrix
A = A_mat
call svd(A,s,vt=vt,err=state)
test = '[S, V^T], overwrite_a=.false.'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
call check(error, all(abs(abs(vt)-abs(vt_sol))<=tol), test//': V^T')
if (allocated(error)) return
!> [S, V^T]. Overwrite A matrix
call svd(A,s,vt=vt,overwrite_a=.true.,err=state)
test = '[S, V^T], overwrite_a=.true.'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
call check(error, all(abs(abs(vt)-abs(vt_sol))<=tol), test//': V^T')
if (allocated(error)) return
!> [U, S, V^T].
A = A_mat
call svd(A,s,u,vt,err=state)
test = '[U, S, V^T]'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(abs(u)-abs(u_sol))<=tol), test//': U')
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
call check(error, all(abs(abs(vt)-abs(vt_sol))<=tol), test//': V^T')
if (allocated(error)) return
!> [U, S, V^T]. Partial storage -> compare until k=2 columns of U rows of V^T
A = A_mat
u = 0
vt = 0
call svd(A,s,u,vt,full_matrices=.false.,err=state)
test = '[U, S, V^T], partial storage'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(abs(u(:,:2))-abs(u_sol(:,:2)))<=tol), test//': U(:,:2)')
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
call check(error, all(abs(abs(vt(:2,:))-abs(vt_sol(:2,:)))<=tol), test//': V^T(:2,:)')
if (allocated(error)) return
end subroutine test_svd_${ri}$
#:endfor
!> Test complex svd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
subroutine test_complex_svd_${ci}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
real(${ck}$), parameter :: tol = sqrt(epsilon(0.0_${ck}$))
real(${ck}$), parameter :: one = 1.0_${ck}$
real(${ck}$), parameter :: zero = 0.0_${ck}$
real(${ck}$), parameter :: sqrt2 = sqrt(2.0_${ck}$)
real(${ck}$), parameter :: rsqrt2 = one/sqrt2
${ct}$, parameter :: csqrt2 = (rsqrt2,zero)
${ct}$, parameter :: isqrt2 = (zero,rsqrt2)
${ct}$, parameter :: cone = (1.0_${ck}$,0.0_${ck}$)
${ct}$, parameter :: cimg = (0.0_${ck}$,1.0_${ck}$)
${ct}$, parameter :: czero = (0.0_${ck}$,0.0_${ck}$)
real(${ck}$), parameter :: s_sol(2) = [sqrt2,sqrt2]
${ct}$, parameter :: A_mat(2,2) = reshape([cone,cimg,cimg,cone],[2,2])
${ct}$, parameter :: u_sol(2,2) = reshape([csqrt2,isqrt2,isqrt2,csqrt2],[2,2])
${ct}$, parameter :: vt_sol(2,2) = reshape([cone,czero,czero,cone],[2,2])
!> Local variables
character(:), allocatable :: test
type(linalg_state_type) :: state
${ct}$ :: A(2,2),u(2,2),vt(2,2)
real(${ck}$) :: s(2)
!> Initialize matrix
A = A_mat
!> Simple subroutine version
call svd(A,s,err=state)
test = '[S], complex subroutine'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
!> Function interface
s = svdvals(A,err=state)
test = 'svdvals, complex function'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
!> [S, U, V^T]
A = A_mat
call svd(A,s,u,vt,overwrite_a=.true.,err=state)
test = '[S, U, V^T], complex'
call check(error,state%ok(),test//': '//state%print())
if (allocated(error)) return
call check(error, all(abs(s-s_sol)<=tol), test//': S')
if (allocated(error)) return
call check(error, all(abs(matmul(u,matmul(diag(s),vt))-A_mat)<=tol), test//': U*S*V^T')
if (allocated(error)) return
end subroutine test_complex_svd_${ci}$
#:endfor
#:for rk,rt,ri in RC_KINDS_TYPES
! Issue #835: bounds checking triggers an error with 1-sized A matrix
subroutine test_svd_row_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
!> Reference solution
type(linalg_state_type) :: state
integer(ilp), parameter :: m = 1, n = 1
real(${rk}$), parameter :: tol = sqrt(epsilon(0.0_${rk}$))
real(${rk}$) :: Arand(m, n), S(n)
${rt}$ :: A(m, n), U(m, m), Vt(n, n)
! Random matrix.
call random_number(Arand)
A = Arand
call svd(A, S, U, Vt, err=state)
call check(error,state%ok(),'1-row SVD: '//state%print())
if (allocated(error)) return
call check(error, abs(S(1)-A(1,1))0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_svd
program test_lstsq
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_svd, only : test_svd
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_svd", test_svd) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_lstsq
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_solve.fypp 0000664 0001750 0001750 00000015734 15135654166 025042 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test linear system solver
module test_linalg_solve
use stdlib_linalg_constants
use stdlib_linalg_state
use stdlib_linalg, only: solve
use testdrive, only: error_type, check, new_unittest, unittest_type
implicit none (type,external)
private
public :: test_linear_systems
contains
!> Solve real and complex linear systems
subroutine test_linear_systems(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in REAL_KINDS_TYPES
call add_test(tests,new_unittest("solve_${ri}$",test_${ri}$_solve))
call add_test(tests,new_unittest("solve_${ri}$_multiple",test_${ri}$_solve_multiple))
#:endfor
#:for ck,ct,ci in CMPLX_KINDS_TYPES
call add_test(tests,new_unittest("solve_complex_${ci}$",test_${ci}$_solve))
call add_test(tests,new_unittest("solve_2x2_complex_${ci}$",test_2x2_${ci}$_solve))
#:endfor
end subroutine test_linear_systems
#:for rk,rt,ri in REAL_KINDS_TYPES
!> Simple linear system
subroutine test_${ri}$_solve(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
${rt}$ :: A(3,3) = transpose(reshape([${rt}$ :: 1, 3, 3, &
1, 3, 4, &
1, 4, 3], [3,3]))
${rt}$ :: b (3) = [${rt}$ :: 1, 4, -1]
${rt}$ :: res(3) = [${rt}$ :: -2, -2, 3]
${rt}$ :: x(3)
x = solve(a,b,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(x-res) Simple linear system with multiple right hand sides
subroutine test_${ri}$_solve_multiple(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
${rt}$ :: A(3,3) = transpose(reshape([${rt}$ :: 1,-1, 2, &
0, 1, 1, &
1,-1, 3], [3,3]))
${rt}$ :: b(3,3) = transpose(reshape([${rt}$ :: 0, 1, 2, &
1,-2,-1, &
2, 3,-1], [3,3]))
${rt}$ :: res(3,3) = transpose(reshape([${rt}$ ::-5,-7,10, &
-1,-4, 2, &
2, 2,-3], [3,3]))
${rt}$ :: x(3,3)
x = solve(a,b,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(x-res) Complex linear system
!> Militaru, Popa, "On the numerical solving of complex linear systems",
!> Int J Pure Appl Math 76(1), 113-122, 2012.
subroutine test_${ri}$_solve(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
${rt}$ :: A(5,5), b(5), res(5), x(5)
! Fill in linear system
A = (0.0_${rk}$,0.0_${rk}$)
A(1:2,1) = [(19.73_${rk}$,0.0_${rk}$),(0.0_${rk}$,-0.51_${rk}$)]
A(1:3,2) = [(12.11_${rk}$,-1.0_${rk}$),(32.3_${rk}$,7.0_${rk}$),(0.0_${rk}$,-0.51_${rk}$)]
A(1:4,3) = [(0.0_${rk}$,5.0_${rk}$),(23.07_${rk}$,0.0_${rk}$),(70.0_${rk}$,7.3_${rk}$),(1.0_${rk}$,1.1_${rk}$)]
A(2:5,4) = [(0.0_${rk}$,1.0_${rk}$),(3.95_${rk}$,0.0_${rk}$),(50.17_${rk}$,0.0_${rk}$),(0.0_${rk}$,-9.351_${rk}$)]
A(3:5,5) = [(19.0_${rk}$,31.83_${rk}$),(45.51_${rk}$,0.0_${rk}$),(55.0_${rk}$,0.0_${rk}$)]
b = [(77.38_${rk}$,8.82_${rk}$),(157.48_${rk}$,19.8_${rk}$),(1175.62_${rk}$,20.69_${rk}$),(912.12_${rk}$,-801.75_${rk}$),(550.0_${rk}$,-1060.4_${rk}$)]
! Exact result
res = [(3.3_${rk}$,-1.0_${rk}$),(1.0_${rk}$,0.17_${rk}$),(5.5_${rk}$,0.0_${rk}$),(9.0_${rk}$,0.0_${rk}$),(10.0_${rk}$,-17.75_${rk}$)]
x = solve(a,b,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(x-res) 2x2 Complex linear system
subroutine test_2x2_${ri}$_solve(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
${rt}$, parameter :: i = (0.0_${rk}$,1.0_${rk}$)
${rt}$ :: A(2,2), b(2), res(2), x(2)
! Fill in linear system
A(1,:) = [ 1+2*i, 2-i]
A(2,:) = [ 2+i , i]
b = [1,-1]
! Exact result
res = [(-0.28_${rk}$,-0.04_${rk}$),(0.36_${rk}$,0.48_${rk}$)]
x = solve(a,b,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(x-res)0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_solve
program test_solve
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_solve, only : test_linear_systems
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_solve", test_linear_systems) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_solve
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_cholesky.fypp 0000664 0001750 0001750 00000007324 15135654166 025527 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test Cholesky factorization
module test_linalg_cholesky
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg, only: cholesky,chol
use stdlib_linalg_state, only: linalg_state_type
implicit none (type,external)
private
public :: test_cholesky_factorization
contains
!> Cholesky factorization tests
subroutine test_cholesky_factorization(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("least_cholesky_${ri}$",test_cholesky_${ri}$))
#:endfor
end subroutine test_cholesky_factorization
!> Cholesky factorization of a random matrix
#:for rk,rt,ri in RC_KINDS_TYPES
subroutine test_cholesky_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: n = 3_ilp
real(${rk}$), parameter :: tol = 100*sqrt(epsilon(0.0_${rk}$))
${rt}$ :: a(n,n), l(n,n)
type(linalg_state_type) :: state
! Set real matrix
a(1,:) = [6, 15, 55]
a(2,:) = [15, 55, 225]
a(3,:) = [55, 225, 979]
! Set result (lower factor)
l(1,:) = [ 2.4495_${rk}$, 0.0000_${rk}$, 0.0000_${rk}$]
l(2,:) = [ 6.1237_${rk}$, 4.1833_${rk}$, 0.0000_${rk}$]
l(3,:) = [22.4537_${rk}$, 20.9165_${rk}$, 6.1101_${rk}$]
! 1) Cholesky factorization with full matrices
call cholesky(a, l, other_zeroed=.true., err=state)
call check(error,state%ok(),'cholesky (subr) :: '//state%print())
if (allocated(error)) return
call check(error, all(abs(a-matmul(l,transpose(l)))0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_cholesky
program test_cholesky
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_cholesky, only : test_cholesky_factorization
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_cholesky", test_cholesky_factorization) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_cholesky
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_determinant.fypp 0000664 0001750 0001750 00000014010 15135654166 026206 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test matrix determinant
module test_linalg_determinant
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg, only: eye, det, linalg_state_type
implicit none (type,external)
private
public :: test_matrix_determinant
contains
!> Matrix inversion tests
subroutine test_matrix_determinant(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt in RC_KINDS_TYPES
#:if rk!="xdp"
call add_test(tests,new_unittest("$eye_det_${rt[0]}$${rk}$",test_${rt[0]}$${rk}$_eye_determinant))
call add_test(tests,new_unittest("$eye_det_multiple_${rt[0]}$${rk}$",test_${rt[0]}$${rk}$_eye_multiple))
#:endif
#:endfor
#:for ck,ct in CMPLX_KINDS_TYPES
#:if ck!="xdp"
call add_test(tests,new_unittest("$complex_det_${rt[0]}$${rk}$",test_${ct[0]}$${ck}$_complex_determinant))
#:endif
#: endfor
end subroutine test_matrix_determinant
#:for rk,rt in RC_KINDS_TYPES
#:if rk!="xdp"
!> Determinant of identity matrix
subroutine test_${rt[0]}$${rk}$_eye_determinant(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp), parameter :: n = 128_ilp
${rt}$ :: a(n,n),deta
${rt}$, allocatable :: aalloc(:,:)
a = eye(n)
!> Determinant function
deta = det(a,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, abs(deta-1.0_${rk}$) Test with allocatable matrix
aalloc = eye(n)
deta = det(aalloc,overwrite_a=.false.,err=state)
call check(error,state%ok(),state%print()//' (allocatable a)')
if (allocated(error)) return
call check(error,allocated(aalloc),'a is still allocated')
if (allocated(error)) return
call check(error, abs(deta-1.0_${rk}$) Determinant of identity matrix multiplier
subroutine test_${rt[0]}$${rk}$_eye_multiple(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp), parameter :: n = 4_ilp
real(${rk}$), parameter :: coef = 0.01_${rk}$
integer(ilp) :: i
${rt}$ :: a(n,n),deta
!> Multiply eye by a very small number
a = eye(n)
do concurrent (i=1:n)
a(i,i) = coef
end do
!> Determinant: small, but a is not singular, because it is a multiple of the identity.
deta = det(a,err=state)
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, abs(deta-coef**n) Determinant of complex identity matrix
#:for ck,ct in CMPLX_KINDS_TYPES
#:if ck!="xdp"
subroutine test_${ct[0]}$${ck}$_complex_determinant(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp) :: i,n
integer(ilp), parameter :: nmax = 10_ilp
${ct}$, parameter :: res(nmax) = [${ct}$::(1,1),(0,2),(-2,2),(-4,0),(-4,-4), &
(0,-8),(8,-8),(16,0),(16,16),(0,32)]
${ct}$, allocatable :: a(:,:)
${ct}$ :: deta(nmax)
!> Test determinant for all sizes, 1:nmax
matrix_size: do n=1,nmax
! Put 1+i on each diagonal element
a = eye(n)
do concurrent (i=1:n)
a(i,i) = (1.0_${ck}$,1.0_${ck}$)
end do
! Expected result
deta(n) = det(a,err=state)
deallocate(a)
if (state%error()) exit matrix_size
end do matrix_size
call check(error,state%ok(),state%print())
if (allocated(error)) return
call check(error, all(abs(res-deta)<=epsilon(0.0_${ck}$)), &
'det((1+i)*eye(n)) does not match result')
end subroutine test_${ct[0]}$${ck}$_complex_determinant
#:endif
#:endfor
! gcc-15 bugfix utility
subroutine add_test(tests,new_test)
type(unittest_type), allocatable, intent(inout) :: tests(:)
type(unittest_type), intent(in) :: new_test
integer :: n
type(unittest_type), allocatable :: new_tests(:)
if (allocated(tests)) then
n = size(tests)
else
n = 0
end if
allocate(new_tests(n+1))
if (n>0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_determinant
program test_det
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_determinant, only : test_matrix_determinant
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_determinant", test_matrix_determinant) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_norm.fypp 0000664 0001750 0001750 00000027755 15135654166 024673 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#! Generate an array rank suffix with the same fixed size for all dimensions.
#!
#! Args:
#! rank (int): Rank of the variable
#! size (int): Size along each dimension
#!
#! Returns:
#! Array rank suffix string (e.g. (4,4,4) if rank = 3 and size = 4)
#!
#:def fixedranksuffix(rank,size)
#{if rank > 0}#(${str(size) + (","+str(size)) * (rank - 1)}$)#{endif}#
#:enddef
! Test vector norms
module test_linalg_norm
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg, only: norm, linalg_state_type
use stdlib_linalg_state, only: linalg_state_type
implicit none (type,external)
contains
!> Vector norm tests
subroutine test_vector_norms(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("strided_1d_norm_${ri}$",test_strided_1d_${ri}$))
#:for rank in range(1, MAXRANK)
call add_test(tests,new_unittest("norm_${ri}$_${rank}$d",test_norm_${ri}$_${rank}$d))
#:endfor
#:for rank in range(2, MAXRANK)
#:if rt.startswith('real')
call add_test(tests,new_unittest("norm2_${ri}$_${rank}$d",test_norm2_${ri}$_${rank}$d))
#:endif
call add_test(tests,new_unittest("maxabs_${ri}$_${rank}$d",test_maxabs_${ri}$_${rank}$d))
call add_test(tests,new_unittest("norm_dimmed_${ri}$_${rank}$d",test_norm_dimmed_${ri}$_${rank}$d))
#:endfor
#:endfor
end subroutine test_vector_norms
#:for rk,rt,ri in RC_KINDS_TYPES
!> Test strided norm
subroutine test_strided_1d_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: m = 8_ilp
integer(ilp), parameter :: n = m**2
real(${rk}$), parameter :: tol = 10*sqrt(epsilon(0.0_${rk}$))
${rt}$, target :: a(n)
${rt}$, allocatable :: slice(:)
${rt}$, pointer :: twod(:,:)
real(${rk}$) :: rea(n),ima(n)
call random_number(rea)
#:if rt.startswith('real')
a = rea
#:else
call random_number(ima)
a = cmplx(rea,ima,kind=${rk}$)
#:endif
! Test sliced array results
slice = a(4:7:59)
call check(error,abs(norm(a(4:7:59),2)-norm(slice,2)) a
call check(error,abs(norm(twod,2)-norm(a,2)) Test several norms with different dimensions
subroutine test_norm_${ri}$_${rank}$d(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp) :: j,order
integer(ilp), parameter :: n = 2_ilp**${rank}$
real(${rk}$), parameter :: tol = 10*sqrt(epsilon(0.0_${rk}$))
${rt}$, allocatable :: a(:), b${ranksuffix(rank)}$
character(64) :: msg
allocate(a(n), b${fixedranksuffix(rank,2)}$)
! Init as a range,but with small elements such that all power norms will
! never overflow, even in single precision
a = [(0.01_${rk}$*(j-n/2_ilp), j=1_ilp,n)]
b = reshape(a, shape(b))
! Test some norms
do order = 1, 10
write(msg,"('reshaped order-',i0,' p-norm is the same')") order
call check(error,abs(norm(a,order)-norm(b,order)) Test Euclidean norm; compare with Fortran intrinsic norm2 for reals
#:if rt.startswith('real')
subroutine test_norm2_${ri}$_${rank}$d(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp) :: j,dim
integer(ilp), parameter :: ndim = ${rank}$
integer(ilp), parameter :: n = 2_ilp**ndim
real(${rk}$), parameter :: tol = 10*sqrt(epsilon(0.0_${rk}$))
${rt}$, allocatable :: a(:), b${ranksuffix(rank)}$
intrinsic :: norm2
character(64) :: msg
allocate(a(n), b${fixedranksuffix(rank,2)}$)
! Init as a range,but with small elements such that all power norms will
! never overflow, even in single precision
a = [(0.01_${rk}$*(j-n/2_ilp), j=1_ilp,n)]
b = reshape(a, shape(b))
! Test some norms
call check(error,abs(norm(a,2) - norm2(a)) Test Infinity norm; compare with Fortran intrinsic max(abs(a))
subroutine test_maxabs_${ri}$_${rank}$d(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp) :: j,dim
integer(ilp), parameter :: ndim = ${rank}$
integer(ilp), parameter :: n = 2_ilp**ndim
real(${rk}$), parameter :: tol = 10*sqrt(epsilon(0.0_${rk}$))
${rt}$, allocatable :: a(:), b${ranksuffix(rank)}$
intrinsic :: maxval, abs
character(128) :: msg
allocate(a(n), b${fixedranksuffix(rank,2)}$)
! Init as a range,but with small elements such that all power norms will
! never overflow, even in single precision
a = [(0.01_${rk}$*(j-n/2_ilp), j=1_ilp,n)]
b = reshape(a, shape(b))
! Test some norms
call check(error,abs(norm(a,'inf') - maxval(abs(a)))0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_norm
program test_norm
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_norm, only : test_vector_norms
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_norm", test_vector_norms) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_norm
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_constrained_lstsq.fypp 0000664 0001750 0001750 00000012547 15135654166 027450 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test least squares solver
module test_linalg_constrained_least_squares
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg, only: constrained_lstsq, solve_constrained_lstsq, constrained_lstsq_space
use stdlib_linalg_state, only: linalg_state_type
implicit none (type,external)
private
public :: test_constrained_least_squares
contains
!> Solve sample least squares problems
subroutine test_constrained_least_squares(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in REAL_KINDS_TYPES
call add_test(tests,new_unittest("constrained_least_squares_randm_${ri}$",test_constrained_lstsq_random_${ri}$))
#:endfor
end subroutine test_constrained_least_squares
#:for rk,rt,ri in REAL_KINDS_TYPES
!> Fit from random array
subroutine test_constrained_lstsq_random_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state
integer(ilp), parameter :: m=5, n=4, p=3
!> Least-squares cost.
${rt}$ :: A(m, n), b(m)
!> Equality constraints.
${rt}$ :: C(p, n), d(p)
!> Solution.
${rt}$ :: x(n), x_true(n)
!> Workspace.
integer(ilp) :: lwork
${rt}$, allocatable :: work(:)
!> Least-squares cost.
A(1, :) = [1.0_${rk}$, 1.0_${rk}$, 1.0_${rk}$, 1.0_${rk}$]
A(2, :) = [1.0_${rk}$, 3.0_${rk}$, 1.0_${rk}$, 1.0_${rk}$]
A(3, :) = [1.0_${rk}$, -1.0_${rk}$, 3.0_${rk}$, 1.0_${rk}$]
A(4, :) = [1.0_${rk}$, 1.0_${rk}$, 1.0_${rk}$, 3.0_${rk}$]
A(5, :) = [1.0_${rk}$, 1.0_${rk}$, 1.0_${rk}$, -1.0_${rk}$]
b = [2.0_${rk}$, 1.0_${rk}$, 6.0_${rk}$, 3.0_${rk}$, 1.0_${rk}$]
!> Equality constraints.
C(1, :) = [1.0_${rk}$, 1.0_${rk}$, 1.0_${rk}$, -1.0_${rk}$]
C(2, :) = [1.0_${rk}$, -1.0_${rk}$, 1.0_${rk}$, 1.0_${rk}$]
C(3, :) = [1.0_${rk}$, 1.0_${rk}$, -1.0_${rk}$, 1.0_${rk}$]
d = [1.0_${rk}$, 3.0_${rk}$, -1.0_${rk}$]
!----- Function interface -----
x = constrained_lstsq(A, b, C, d, err=state)
x_true = [0.5_${rk}$, -0.5_${rk}$, 1.5_${rk}$, 0.5_${rk}$]
call check(error, state%ok(), state%print())
if (allocated(error)) return
call check(error, all(abs(x-x_true) < 1.0e-4_${rk}$), 'Solver converged')
if (allocated(error)) return
!----- Subroutine interface -----
call solve_constrained_lstsq(A, b, C, d, x, err=state)
call check(error, state%ok(), state%print())
if (allocated(error)) return
call check(error, all(abs(x-x_true) < 1.0e-4_${rk}$), 'Solver converged')
if (allocated(error)) return
!----- Pre-allocated storage -----
call constrained_lstsq_space(A, C, lwork, err=state)
call check(error, state%ok(), state%print())
if (allocated(error)) return
allocate(work(lwork))
call solve_constrained_lstsq(A, b, C, d, x, storage=work, err=state)
call check(error, state%ok(), state%print())
if (allocated(error)) return
call check(error, all(abs(x-x_true) < 1.0e-4_${rk}$), 'Solver converged')
if (allocated(error)) return
!----- Overwrite matrices (performance) -----
call solve_constrained_lstsq(A, b, C, d, x, storage=work, overwrite_matrices=.true., err=state)
call check(error, state%ok(), state%print())
if (allocated(error)) return
call check(error, all(abs(x-x_true) < 1.0e-4_${rk}$), 'Solver converged')
if (allocated(error)) return
end subroutine test_constrained_lstsq_random_${ri}$
#:endfor
! gcc-15 bugfix utility
subroutine add_test(tests,new_test)
type(unittest_type), allocatable, intent(inout) :: tests(:)
type(unittest_type), intent(in) :: new_test
integer :: n
type(unittest_type), allocatable :: new_tests(:)
if (allocated(tests)) then
n = size(tests)
else
n = 0
end if
allocate(new_tests(n+1))
if (n>0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_constrained_least_squares
program test_constrained_lstsq
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_constrained_least_squares, only : test_constrained_least_squares
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_constrained_least_squares", test_constrained_least_squares) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_constrained_lstsq
fortran-lang-stdlib-0ede301/test/linalg/test_linalg_qr.fypp 0000664 0001750 0001750 00000012330 15135654166 024321 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Test QR factorization
module test_linalg_qr
use testdrive, only: error_type, check, new_unittest, unittest_type
use stdlib_linalg_constants
use stdlib_linalg_state, only: LINALG_VALUE_ERROR,linalg_state_type
use stdlib_linalg, only: qr,qr_space
use ieee_arithmetic, only: ieee_value,ieee_quiet_nan
implicit none (type,external)
public :: test_qr_factorization
contains
!> QR factorization tests
subroutine test_qr_factorization(tests)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: tests(:)
allocate(tests(0))
#:for rk,rt,ri in RC_KINDS_TYPES
call add_test(tests,new_unittest("qr_random_${ri}$",test_qr_random_${ri}$))
#:endfor
end subroutine test_qr_factorization
!> QR factorization of a random matrix
#:for rk,rt,ri in RC_KINDS_TYPES
subroutine test_qr_random_${ri}$(error)
type(error_type), allocatable, intent(out) :: error
integer(ilp), parameter :: m = 15_ilp
integer(ilp), parameter :: n = 4_ilp
integer(ilp), parameter :: k = min(m,n)
real(${rk}$), parameter :: tol = 100*sqrt(epsilon(0.0_${rk}$))
${rt}$ :: a(m,n),aorig(m,n),q(m,m),r(m,n),qred(m,k),rred(k,n),qerr(m,6),rerr(6,n)
real(${rk}$) :: rea(m,n),ima(m,n)
integer(ilp) :: lwork
${rt}$, allocatable :: work(:)
type(linalg_state_type) :: state
call random_number(rea)
#:if rt.startswith('complex')
call random_number(ima)
a = cmplx(rea,ima,kind=${rk}$)
#:else
a = rea
#:endif
aorig = a
! 1) QR factorization with full matrices. Input NaNs to be sure Q and R are OK on return
q = ieee_value(0.0_${rk}$,ieee_quiet_nan)
r = ieee_value(0.0_${rk}$,ieee_quiet_nan)
call qr(a,q,r,err=state)
! Check return code
call check(error,state%ok(),state%print())
if (allocated(error)) return
! Check solution
call check(error, all(abs(a-matmul(q,r))0) new_tests(1:n) = tests(1:n)
new_tests(1+n) = new_test
call move_alloc(from=new_tests,to=tests)
end subroutine add_test
end module test_linalg_qr
program test_qr
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg_qr, only : test_qr_factorization
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg_qr", test_qr_factorization) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program test_qr
fortran-lang-stdlib-0ede301/test/linalg/test_linalg.fypp 0000664 0001750 0001750 00000107735 15135654166 023635 0 ustar alastair alastair #:include "common.fypp"
#:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES
module test_linalg
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64
use stdlib_linalg, only: diag, eye, trace, outer_product, cross_product, kronecker_product, hermitian
use stdlib_linalg_state, only: linalg_state_type, LINALG_SUCCESS, linalg_error_handling
implicit none
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
#:if WITH_QP
real(qp), parameter :: qptol = 1000 * epsilon(1._qp)
#:endif
contains
!> Collect all exported unit tests
subroutine collect_linalg(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("eye", test_eye), &
new_unittest("diag_rsp", test_diag_rsp), &
new_unittest("diag_rsp_k", test_diag_rsp_k), &
new_unittest("diag_rdp", test_diag_rdp), &
new_unittest("diag_rqp", test_diag_rqp), &
new_unittest("diag_csp", test_diag_csp), &
new_unittest("diag_cdp", test_diag_cdp), &
new_unittest("diag_cqp", test_diag_cqp), &
new_unittest("diag_int8", test_diag_int8), &
new_unittest("diag_int16", test_diag_int16), &
new_unittest("diag_int32", test_diag_int32), &
new_unittest("diag_int64", test_diag_int64), &
new_unittest("trace_rsp", test_trace_rsp), &
new_unittest("trace_rsp_nonsquare", test_trace_rsp_nonsquare), &
new_unittest("trace_rdp", test_trace_rdp), &
new_unittest("trace_rdp_nonsquare", test_trace_rdp_nonsquare), &
new_unittest("trace_rqp", test_trace_rqp), &
new_unittest("trace_csp", test_trace_csp), &
new_unittest("trace_cdp", test_trace_cdp), &
new_unittest("trace_cqp", test_trace_cqp), &
new_unittest("trace_int8", test_trace_int8), &
new_unittest("trace_int16", test_trace_int16), &
new_unittest("trace_int32", test_trace_int32), &
new_unittest("trace_int64", test_trace_int64), &
#:for k1, t1 in RCI_KINDS_TYPES
new_unittest("kronecker_product_${t1[0]}$${k1}$", test_kronecker_product_${t1[0]}$${k1}$), &
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
new_unittest("hermitian_${t1[0]}$${k1}$", test_hermitian_${t1[0]}$${k1}$), &
#:endfor
new_unittest("outer_product_rsp", test_outer_product_rsp), &
new_unittest("outer_product_rdp", test_outer_product_rdp), &
new_unittest("outer_product_rqp", test_outer_product_rqp), &
new_unittest("outer_product_csp", test_outer_product_csp), &
new_unittest("outer_product_cdp", test_outer_product_cdp), &
new_unittest("outer_product_cqp", test_outer_product_cqp), &
new_unittest("outer_product_int8", test_outer_product_int8), &
new_unittest("outer_product_int16", test_outer_product_int16), &
new_unittest("outer_product_int32", test_outer_product_int32), &
new_unittest("outer_product_int64", test_outer_product_int64), &
new_unittest("cross_product_rsp", test_cross_product_rsp), &
new_unittest("cross_product_rdp", test_cross_product_rdp), &
new_unittest("cross_product_rqp", test_cross_product_rqp), &
new_unittest("cross_product_csp", test_cross_product_csp), &
new_unittest("cross_product_cdp", test_cross_product_cdp), &
new_unittest("cross_product_cqp", test_cross_product_cqp), &
new_unittest("cross_product_int8", test_cross_product_int8), &
new_unittest("cross_product_int16", test_cross_product_int16), &
new_unittest("cross_product_int32", test_cross_product_int32), &
new_unittest("cross_product_int64", test_cross_product_int64), &
new_unittest("state_handling", test_state_handling) &
]
end subroutine collect_linalg
subroutine test_eye(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(sp), allocatable :: rye(:,:)
complex(sp) :: cye(7,7)
integer :: i
call check(error, all(eye(3,3) == diag([(1,i=1,3)])), &
"all(eye(3,3) == diag([(1,i=1,3)])) failed.")
if (allocated(error)) return
rye = eye(3,4)
call check(error, sum(abs(rye(:,1:3) - diag([(1.0_sp,i=1,3)]))) < sptol, &
"sum(abs(rye(:,1:3) - diag([(1.0_sp,i=1,3)]))) < sptol failed")
if (allocated(error)) return
call check(error, all(eye(5) == diag([(1,i=1,5)])), &
"all(eye(5) == diag([(1,i=1,5)] failed.")
if (allocated(error)) return
rye = eye(6)
call check(error, sum(rye - diag([(1.0_sp,i=1,6)])) < sptol, &
"sum(rye - diag([(1.0_sp,i=1,6)])) < sptol failed.")
if (allocated(error)) return
cye = eye(7)
call check(error, abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol, &
"abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol failed.")
end subroutine test_eye
subroutine test_diag_rsp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
real(sp) :: v(n), a(n,n), b(n,n)
integer :: i,j
v = [(i,i=1,n)]
a = diag(v)
b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
call check(error, all(a == b), &
"all(a == b) failed.")
if (allocated(error)) return
call check(error, all(diag(3*a) == 3*v), &
"all(diag(3*a) == 3*v) failed.")
end subroutine test_diag_rsp
subroutine test_diag_rsp_k(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 4
real(sp) :: a(n,n), b(n,n)
integer :: i,j
a = diag([(1._sp,i=1,n-1)],-1)
b = reshape([((merge(1,0,i==j+1), i=1,n), j=1,n)], [n,n])
call check(error, all(a == b), &
"all(a == b) failed.")
if (allocated(error)) return
call check(error, sum(diag(a,-1)) - (n-1) < sptol, &
"sum(diag(a,-1)) - (n-1) < sptol failed.")
if (allocated(error)) return
call check(error, all(a == transpose(diag([(1._sp,i=1,n-1)],1))), &
"all(a == transpose(diag([(1._sp,i=1,n-1)],1))) failed")
if (allocated(error)) return
call random_number(a)
do i = 1, n
call check(error, size(diag(a,i)) == n-i, &
"size(diag(a,i)) == n-i failed.")
if (allocated(error)) return
end do
call check(error, size(diag(a,n+1)) == 0, &
"size(diag(a,n+1)) == 0 failed.")
end subroutine test_diag_rsp_k
subroutine test_diag_rdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
real(dp) :: v(n), a(n,n), b(n,n)
integer :: i,j
v = [(i,i=1,n)]
a = diag(v)
b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
call check(error, all(a == b), &
"all(a == b) failed.")
if (allocated(error)) return
call check(error, all(diag(3*a) == 3*v), &
"all(diag(3*a) == 3*v) failed.")
end subroutine test_diag_rdp
subroutine test_diag_rqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 3
real(qp) :: v(n), a(n,n), b(n,n)
integer :: i,j
v = [(i,i=1,n)]
a = diag(v)
b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
call check(error, all(a == b), &
"all(a == b) failed.")
if (allocated(error)) return
call check(error, all(diag(3*a) == 3*v), &
"all(diag(3*a) == 3*v) failed.")
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_diag_rqp
subroutine test_diag_csp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
complex(sp) :: a(n,n), b(n,n)
complex(sp), parameter :: i_ = cmplx(0,1,kind=sp)
integer :: i,j
a = diag([(i,i=1,n)]) + diag([(i_,i=1,n)])
b = reshape([((merge(i + 1*i_,0*i_,i==j), i=1,n), j=1,n)], [n,n])
call check(error, all(a == b), &
"all(a == b) failed.")
if (allocated(error)) return
call check(error, all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol), &
"all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol)")
if (allocated(error)) return
call check(error, all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol), &
"all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol)")
end subroutine test_diag_csp
subroutine test_diag_cdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
complex(dp) :: a(n,n)
complex(dp), parameter :: i_ = cmplx(0,1,kind=dp)
a = diag([i_],-2) + diag([i_],2)
call check(error, a(3,1) == i_ .and. a(1,3) == i_, &
"a(3,1) == i_ .and. a(1,3) == i_ failed.")
end subroutine test_diag_cdp
subroutine test_diag_cqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 3
complex(qp) :: a(n,n)
complex(qp), parameter :: i_ = cmplx(0,1,kind=qp)
a = diag([i_,i_],-1) + diag([i_,i_],1)
call check(error, all(diag(a,-1) == i_) .and. all(diag(a,1) == i_), &
"all(diag(a,-1) == i_) .and. all(diag(a,1) == i_) failed.")
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_diag_cqp
subroutine test_diag_int8(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int8), allocatable :: a(:,:)
integer :: i
logical, allocatable :: mask(:,:)
a = reshape([(i,i=1,n**2)],[n,n])
mask = merge(.true.,.false.,eye(n) == 1)
call check(error, all(diag(a) == pack(a,mask)), &
"all(diag(a) == pack(a,mask)) failed.")
if (allocated(error)) return
call check(error, all(diag(diag(a)) == merge(a,0_int8,mask)), &
"all(diag(diag(a)) == merge(a,0_int8,mask)) failed.")
end subroutine test_diag_int8
subroutine test_diag_int16(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 4
integer(int16), allocatable :: a(:,:)
integer :: i
logical, allocatable :: mask(:,:)
a = reshape([(i,i=1,n**2)],[n,n])
mask = merge(.true.,.false.,eye(n) == 1)
call check(error, all(diag(a) == pack(a,mask)), &
"all(diag(a) == pack(a,mask))")
if (allocated(error)) return
call check(error, all(diag(diag(a)) == merge(a,0_int16,mask)), &
"all(diag(diag(a)) == merge(a,0_int16,mask)) failed.")
end subroutine test_diag_int16
subroutine test_diag_int32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int32) :: a(n,n)
logical :: mask(n,n)
integer :: i, j
mask = reshape([((merge(.true.,.false.,i==j+1), i=1,n), j=1,n)], [n,n])
a = 0
a = unpack([1_int32,1_int32],mask,a)
call check(error, all(diag([1,1],-1) == a), &
"all(diag([1,1],-1) == a) failed.")
if (allocated(error)) return
call check(error, all(diag([1,1],1) == transpose(a)), &
"all(diag([1,1],1) == transpose(a)) failed.")
end subroutine test_diag_int32
subroutine test_diag_int64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 4
integer(int64) :: a(n,n), c(0:2*n-1)
logical :: mask(n,n)
integer :: i, j
mask = reshape([((merge(.true.,.false.,i+1==j), i=1,n), j=1,n)], [n,n])
a = 0
a = unpack([1_int64,1_int64,1_int64],mask,a)
call check(error, all(diag([1,1,1],1) == a), &
"all(diag([1,1,1],1) == a) failed.")
if (allocated(error)) return
call check(error, all(diag([1,1,1],-1) == transpose(a)), &
"all(diag([1,1,1],-1) == transpose(a)) failed.")
if (allocated(error)) return
! Fill array c with Catalan numbers
do i = 0, 2*n-1
c(i) = catalan_number(i)
end do
! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1)
do i = 1, n
do j = 1, n
a(i,j) = c(i-1 + (j-1))
end do
end do
call check(error, all(diag(a,-2) == diag(a,2)), &
"all(diag(a,-2) == diag(a,2))")
end subroutine test_diag_int64
subroutine test_trace_rsp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 5
real(sp) :: a(n,n)
integer :: i
a = reshape([(i,i=1,n**2)],[n,n])
call check(error, abs(trace(a) - sum(diag(a))) < sptol, &
"abs(trace(a) - sum(diag(a))) < sptol failed.")
end subroutine test_trace_rsp
subroutine test_trace_rsp_nonsquare(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 4
real(sp) :: a(n,n+1), ans
integer :: i
! 1 5 9 13 17
! 2 6 10 14 18
! 3 7 11 15 19
! 4 8 12 16 20
a = reshape([(i,i=1,n*(n+1))],[n,n+1])
ans = sum([1._sp,6._sp,11._sp,16._sp])
call check(error, abs(trace(a) - ans) < sptol, &
"abs(trace(a) - ans) < sptol failed.")
end subroutine test_trace_rsp_nonsquare
subroutine test_trace_rdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 4
real(dp) :: a(n,n)
integer :: i
a = reshape([(i,i=1,n**2)],[n,n])
call check(error, abs(trace(a) - sum(diag(a))) < dptol, &
"abs(trace(a) - sum(diag(a))) < dptol failed.")
end subroutine test_trace_rdp
subroutine test_trace_rdp_nonsquare(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 4
real(dp) :: a(n,n-1), ans
integer :: i
! 1 25 81
! 4 36 100
! 9 49 121
! 16 64 144
a = reshape([(i**2,i=1,n*(n-1))],[n,n-1])
ans = sum([1._dp,36._dp,121._dp])
call check(error, abs(trace(a) - ans) < dptol, &
"abs(trace(a) - ans) < dptol failed.")
end subroutine test_trace_rdp_nonsquare
subroutine test_trace_rqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 3
real(qp) :: a(n,n)
integer :: i
a = reshape([(i,i=1,n**2)],[n,n])
call check(error, abs(trace(a) - sum(diag(a))) < qptol, &
"abs(trace(a) - sum(diag(a))) < qptol failed.")
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_trace_rqp
subroutine test_trace_csp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 5
real(sp) :: re(n,n), im(n,n)
complex(sp) :: a(n,n), b(n,n)
complex(sp), parameter :: i_ = cmplx(0,1,kind=sp)
call random_number(re)
call random_number(im)
a = re + im*i_
call random_number(re)
call random_number(im)
b = re + im*i_
! tr(A + B) = tr(A) + tr(B)
call check(error, abs(trace(a+b) - (trace(a) + trace(b))) < sptol, &
"abs(trace(a+b) - (trace(a) + trace(b))) < sptol failed.")
end subroutine test_trace_csp
subroutine test_trace_cdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
complex(dp) :: a(n,n), ans
complex(dp), parameter :: i_ = cmplx(0,1,kind=dp)
integer :: j
a = reshape([(j + (n**2 - (j-1))*i_,j=1,n**2)],[n,n])
ans = cmplx(15,15,kind=dp) !(1 + 5 + 9) + (9 + 5 + 1)i
call check(error, abs(trace(a) - ans) < dptol, &
"abs(trace(a) - ans) < dptol failed.")
end subroutine test_trace_cdp
subroutine test_trace_cqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 3
complex(qp) :: a(n,n)
complex(qp), parameter :: i_ = cmplx(0,1,kind=qp)
a = 3*eye(n) + 4*eye(n)*i_ ! pythagorean triple
call check(error, abs(trace(a)) - 3*5.0_qp < qptol, &
"abs(trace(a)) - 3*5.0_qp < qptol failed.")
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_trace_cqp
subroutine test_trace_int8(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int8) :: a(n,n)
integer :: i
a = reshape([(i**2,i=1,n**2)],[n,n])
call check(error, trace(a) == (1 + 25 + 81), &
"trace(a) == (1 + 25 + 81) failed.")
end subroutine test_trace_int8
subroutine test_trace_int16(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int16) :: a(n,n)
integer :: i
a = reshape([(i**3,i=1,n**2)],[n,n])
call check(error, trace(a) == (1 + 125 + 729), &
"trace(a) == (1 + 125 + 729) failed.")
end subroutine test_trace_int16
subroutine test_trace_int32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int32) :: a(n,n)
integer :: i
a = reshape([(i**4,i=1,n**2)],[n,n])
call check(error, trace(a) == (1 + 625 + 6561), &
"trace(a) == (1 + 625 + 6561) failed.")
end subroutine test_trace_int32
subroutine test_trace_int64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 5
integer, parameter :: nd = 2*n-1 ! number of diagonals
integer :: i, j
integer(int64) :: c(0:nd), H(n,n)
! Fill array with Catalan numbers
do i = 0, nd
c(i) = catalan_number(i)
end do
! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1)
do i = 1, n
do j = 1, n
H(i,j) = c(i-1 + (j-1))
end do
end do
call check(error, trace(h) == sum(c(0:nd:2)), &
"trace(h) == sum(c(0:nd:2)) failed.")
end subroutine test_trace_int64
#:for k1, t1 in RCI_KINDS_TYPES
subroutine test_kronecker_product_${t1[0]}$${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: m1 = 1, n1 = 2, m2 = 2, n2 = 3
${t1}$, dimension(m1*m2,n1*n2), parameter :: expected &
= transpose(reshape([1,2,3, 2,4,6, 2,4,6, 4,8,12], [m2*n2, m1*n1]))
${t1}$, parameter :: tol = 1.e-6
${t1}$ :: A(m1,n1), B(m2,n2)
${t1}$ :: C(m1*m2,n1*n2), diff(m1*m2,n1*n2)
integer :: i,j
do j = 1, n1
do i = 1, m1
A(i,j) = i*j ! A = [1, 2]
end do
end do
do j = 1, n2
do i = 1, m2
B(i,j) = i*j ! B = [[1, 2, 3], [2, 4, 6]]
end do
end do
C = kronecker_product(A,B)
diff = C - expected
call check(error, all(abs(diff) .le. abs(tol)), "all(abs(diff) .le. abs(tol)) failed")
! Expected: C = [1*B, 2*B] = [[1,2,3, 2,4,6], [2,4,6, 4, 8, 12]]
end subroutine test_kronecker_product_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
subroutine test_hermitian_${t1[0]}$${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: m = 2, n = 3
${t1}$, dimension(m,n) :: A
${t1}$, dimension(n,m) :: AT, expected, diff
real(${k1}$), parameter :: tol = 1.e-6_${k1}$
integer :: i,j
do concurrent (i=1:m,j=1:n)
A (i,j) = cmplx(i,-j,kind=${k1}$)
expected(j,i) = cmplx(i,+j,kind=${k1}$)
end do
AT = hermitian(A)
diff = AT - expected
call check(error, all(abs(diff) < abs(tol)), "hermitian: all(abs(diff) < abs(tol)) failed")
end subroutine test_hermitian_${t1[0]}$${k1}$
#:endfor
subroutine test_outer_product_rsp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 2
real(sp) :: u(n), v(n), expected(n,n), diff(n,n)
u = [1.,2.]
v = [1.,3.]
expected = reshape([1.,2.,3.,6.],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) < sptol), &
"all(abs(diff) < sptol) failed.")
end subroutine test_outer_product_rsp
subroutine test_outer_product_rdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 2
real(dp) :: u(n), v(n), expected(n,n), diff(n,n)
u = [1.,2.]
v = [1.,3.]
expected = reshape([1.,2.,3.,6.],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) < dptol), &
"all(abs(diff) < dptol) failed.")
end subroutine test_outer_product_rdp
subroutine test_outer_product_rqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 2
real(qp) :: u(n), v(n), expected(n,n), diff(n,n)
u = [1.,2.]
v = [1.,3.]
expected = reshape([1.,2.,3.,6.],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) < qptol), &
"all(abs(diff) < qptol) failed.")
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_outer_product_rqp
subroutine test_outer_product_csp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 2
complex(sp) :: u(n), v(n), expected(n,n), diff(n,n)
u = [cmplx(1.,1.),cmplx(2.,0.)]
v = [cmplx(1.,0.),cmplx(3.,1.)]
expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) < sptol), &
"all(abs(diff) < sptol) failed.")
end subroutine test_outer_product_csp
subroutine test_outer_product_cdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 2
complex(dp) :: u(n), v(n), expected(n,n), diff(n,n)
u = [cmplx(1.,1.),cmplx(2.,0.)]
v = [cmplx(1.,0.),cmplx(3.,1.)]
expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) < dptol), &
"all(abs(diff) < dptol) failed.")
end subroutine test_outer_product_cdp
subroutine test_outer_product_cqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 2
complex(qp) :: u(n), v(n), expected(n,n), diff(n,n)
u = [cmplx(1.,1.),cmplx(2.,0.)]
v = [cmplx(1.,0.),cmplx(3.,1.)]
expected = reshape([cmplx(1.,1.),cmplx(2.,0.),cmplx(2.,4.),cmplx(6.,2.)],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) < qptol), &
"all(abs(diff) < qptol) failed.")
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_outer_product_cqp
subroutine test_outer_product_int8(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 2
integer(int8) :: u(n), v(n), expected(n,n), diff(n,n)
u = [1,2]
v = [1,3]
expected = reshape([1,2,3,6],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) == 0), &
"all(abs(diff) == 0) failed.")
end subroutine test_outer_product_int8
subroutine test_outer_product_int16(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 2
integer(int16) :: u(n), v(n), expected(n,n), diff(n,n)
u = [1,2]
v = [1,3]
expected = reshape([1,2,3,6],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) == 0), &
"all(abs(diff) == 0) failed.")
end subroutine test_outer_product_int16
subroutine test_outer_product_int32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 2
integer(int32) :: u(n), v(n), expected(n,n), diff(n,n)
u = [1,2]
v = [1,3]
expected = reshape([1,2,3,6],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) == 0), &
"all(abs(diff) == 0) failed.")
end subroutine test_outer_product_int32
subroutine test_outer_product_int64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 2
integer(int64) :: u(n), v(n), expected(n,n), diff(n,n)
u = [1,2]
v = [1,3]
expected = reshape([1,2,3,6],[n,n])
diff = expected - outer_product(u,v)
call check(error, all(abs(diff) == 0), &
"all(abs(diff) == 0) failed.")
end subroutine test_outer_product_int64
subroutine test_cross_product_int8(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int8) :: u(n), v(n), expected(n), diff(n)
u = [1,0,0]
v = [0,1,0]
expected = [0,0,1]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) == 0), &
"cross_product(u,v) == expected failed.")
end subroutine test_cross_product_int8
subroutine test_cross_product_int16(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int16) :: u(n), v(n), expected(n), diff(n)
u = [1,0,0]
v = [0,1,0]
expected = [0,0,1]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) == 0), &
"cross_product(u,v) == expected failed.")
end subroutine test_cross_product_int16
subroutine test_cross_product_int32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int32) :: u(n), v(n), expected(n), diff(n)
write(*,*) "test_cross_product_int32"
u = [1,0,0]
v = [0,1,0]
expected = [0,0,1]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) == 0), &
"cross_product(u,v) == expected failed.")
end subroutine test_cross_product_int32
subroutine test_cross_product_int64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
integer(int64) :: u(n), v(n), expected(n), diff(n)
write(*,*) "test_cross_product_int64"
u = [1,0,0]
v = [0,1,0]
expected = [0,0,1]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) == 0), &
"cross_product(u,v) == expected failed.")
end subroutine test_cross_product_int64
subroutine test_cross_product_rsp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
real(sp) :: u(n), v(n), expected(n), diff(n)
write(*,*) "test_cross_product_rsp"
u = [1.1_sp,2.5_sp,2.4_sp]
v = [0.5_sp,1.5_sp,2.5_sp]
expected = [2.65_sp,-1.55_sp,0.4_sp]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) < sptol), &
"all(abs(cross_product(u,v)-expected)) < sptol failed.")
end subroutine test_cross_product_rsp
subroutine test_cross_product_rdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
real(dp) :: u(n), v(n), expected(n), diff(n)
write(*,*) "test_cross_product_rdp"
u = [1.1_dp,2.5_dp,2.4_dp]
v = [0.5_dp,1.5_dp,2.5_dp]
expected = [2.65_dp,-1.55_dp,0.4_dp]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) < dptol), &
"all(abs(cross_product(u,v)-expected)) < dptol failed.")
end subroutine test_cross_product_rdp
subroutine test_cross_product_rqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 3
real(qp) :: u(n), v(n), expected(n), diff(n)
write(*,*) "test_cross_product_rqp"
u = [1.1_qp,2.5_qp,2.4_qp]
v = [0.5_qp,1.5_qp,2.5_qp]
expected = [2.65_qp,-1.55_qp,0.4_qp]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) < qptol), &
"all(abs(cross_product(u,v)-expected)) < qptol failed.")
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_cross_product_rqp
subroutine test_cross_product_csp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
complex(sp) :: u(n), v(n), expected(n), diff(n)
write(*,*) "test_cross_product_csp"
u = [cmplx(0,1,sp),cmplx(1,0,sp),cmplx(0,0,sp)]
v = [cmplx(1,1,sp),cmplx(0,0,sp),cmplx(1,0,sp)]
expected = [cmplx(1,0,sp),cmplx(0,-1,sp),cmplx(-1,-1,sp)]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) < sptol), &
"all(abs(cross_product(u,v)-expected)) < sptol failed.")
end subroutine test_cross_product_csp
subroutine test_cross_product_cdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 3
complex(dp) :: u(n), v(n), expected(n), diff(n)
write(*,*) "test_cross_product_cdp"
u = [cmplx(0,1,dp),cmplx(1,0,dp),cmplx(0,0,dp)]
v = [cmplx(1,1,dp),cmplx(0,0,dp),cmplx(1,0,dp)]
expected = [cmplx(1,0,dp),cmplx(0,-1,dp),cmplx(-1,-1,dp)]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) < dptol), &
"all(abs(cross_product(u,v)-expected)) < dptol failed.")
end subroutine test_cross_product_cdp
subroutine test_cross_product_cqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 3
complex(qp) :: u(n), v(n), expected(n), diff(n)
write(*,*) "test_cross_product_cqp"
u = [cmplx(0,1,qp),cmplx(1,0,qp),cmplx(0,0,qp)]
v = [cmplx(1,1,qp),cmplx(0,0,qp),cmplx(1,0,qp)]
expected = [cmplx(1,0,qp),cmplx(0,-1,qp),cmplx(-1,-1,qp)]
diff = expected - cross_product(u,v)
call check(error, all(abs(diff) < qptol), &
"all(abs(cross_product(u,v)-expected)) < qptol failed.")
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_cross_product_cqp
subroutine test_state_handling(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(linalg_state_type) :: state,state_out
state = linalg_state_type(LINALG_SUCCESS,' 32-bit real: ',1.0_sp)
call check(error, &
state%message==' 32-bit real: 1.00000000E+00', &
"malformed state message with 32-bit reals.")
if (allocated(error)) return
state = linalg_state_type(LINALG_SUCCESS,' 64-bit real: ',1.0_dp)
call check(error, &
state%message==' 64-bit real: 1.0000000000000000E+000', &
"malformed state message with 64-bit reals.")
if (allocated(error)) return
#:if WITH_QP
state = linalg_state_type(LINALG_SUCCESS,' 128-bit real: ',1.0_qp)
call check(error, &
state%message==' 128-bit real: 1.00000000000000000000000000000000000E+0000', &
"malformed state message with 128-bit reals.")
if (allocated(error)) return
#:endif
state = linalg_state_type(LINALG_SUCCESS,' 32-bit complex: ',(1.0_sp,1.0_sp))
call check(error, &
state%message==' 32-bit complex: (1.00000000E+00,1.00000000E+00)', &
"malformed state message with 32-bit complex: "//trim(state%message))
if (allocated(error)) return
state = linalg_state_type(LINALG_SUCCESS,' 64-bit complex: ',(1.0_dp,1.0_dp))
call check(error, &
state%message==' 64-bit complex: (1.0000000000000000E+000,1.0000000000000000E+000)', &
"malformed state message with 64-bit complex.")
if (allocated(error)) return
#:if WITH_QP
state = linalg_state_type(LINALG_SUCCESS,'128-bit complex: ',(1.0_qp,1.0_qp))
call check(error, state%message== &
'128-bit complex: (1.00000000000000000000000000000000000E+0000,1.00000000000000000000000000000000000E+0000)', &
"malformed state message with 128-bit complex.")
#:endif
state = linalg_state_type(LINALG_SUCCESS,' 32-bit array: ',[(1.0_sp,0.0_sp),(0.0_sp,1.0_sp)])
call check(error, state%message== &
' 32-bit array: [(1.00000000E+00,0.00000000E+00) (0.00000000E+00,1.00000000E+00)]', &
"malformed state message with 32-bit real array.")
if (allocated(error)) return
!> State flag with location
state = linalg_state_type('test_formats',LINALG_SUCCESS,' 32-bit real: ',1.0_sp)
call check(error, &
state%print()=='[test_formats] returned Success!', &
"malformed state message with 32-bit real and location.")
if (allocated(error)) return
!> Test error handling procedure
call linalg_error_handling(state,state_out)
call check(error, state%print()==state_out%print(), &
"malformed state message on return from error handling procedure.")
end subroutine test_state_handling
pure recursive function catalan_number(n) result(value)
integer, intent(in) :: n
integer :: value
integer :: i
if (n <= 1) then
value = 1
else
value = 0
do i = 0, n-1
value = value + catalan_number(i)*catalan_number(n-i-1)
end do
end if
end function
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linalg, only : collect_linalg
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linalg", collect_linalg) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/terminal/ 0000775 0001750 0001750 00000000000 15135654166 020760 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/terminal/CMakeLists.txt 0000664 0001750 0001750 00000000020 15135654166 023510 0 ustar alastair alastair ADDTEST(colors)
fortran-lang-stdlib-0ede301/test/terminal/test_colors.f90 0000664 0001750 0001750 00000004721 15135654166 023644 0 ustar alastair alastair ! SPDX-Identifier: MIT
module test_colors
use stdlib_ansi, only : fg_color_red, bg_color_yellow, style_bold, to_string
use testdrive, only : new_unittest, unittest_type, error_type, check
implicit none
contains
!> Collect all exported unit tests
subroutine collect_colors(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("fg_color", test_fg_color), &
new_unittest("bg_color", test_bg_color), &
new_unittest("style", test_style) &
]
end subroutine collect_colors
subroutine test_fg_color(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: str
str = to_string(fg_color_red)
call check(error, iachar(str(1:1)), 27)
if (allocated(error)) return
call check(error, str(2:), "[0;31m")
end subroutine test_fg_color
subroutine test_bg_color(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: str
str = to_string(bg_color_yellow)
call check(error, iachar(str(1:1)), 27)
if (allocated(error)) return
call check(error, str(2:), "[0;43m")
end subroutine test_bg_color
subroutine test_style(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: str
str = to_string(style_bold)
call check(error, iachar(str(1:1)), 27)
if (allocated(error)) return
call check(error, str(2:), "[0;1m")
end subroutine test_style
end module test_colors
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_colors, only : collect_colors
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("colors", collect_colors) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/array/ 0000775 0001750 0001750 00000000000 15135654166 020263 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/array/test_logicalloc.f90 0000664 0001750 0001750 00000022011 15135654166 023746 0 ustar alastair alastair ! SPDX-Identifier: MIT
module test_logicalloc
use stdlib_array, only : trueloc, falseloc
use stdlib_kinds, only : dp, i8 => int64
use stdlib_strings, only : to_string
use testdrive, only : new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_logicalloc
contains
!> Collect all exported unit tests
subroutine collect_logicalloc(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("trueloc-empty", test_trueloc_empty), &
new_unittest("trueloc-all", test_trueloc_all), &
new_unittest("trueloc-where", test_trueloc_where), &
new_unittest("trueloc-merge", test_trueloc_merge), &
new_unittest("trueloc-pack", test_trueloc_pack), &
new_unittest("falseloc-empty", test_falseloc_empty), &
new_unittest("falseloc-all", test_falseloc_all), &
new_unittest("falseloc-where", test_falseloc_where), &
new_unittest("falseloc-merge", test_falseloc_merge), &
new_unittest("falseloc-pack", test_falseloc_pack) &
]
end subroutine collect_logicalloc
subroutine test_trueloc_empty(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:), bvec(:)
do ndim = 100, 12000, 100
allocate(avec(ndim))
call random_number(avec)
bvec = avec
bvec(trueloc(bvec < 0)) = 0.0
call check(error, all(bvec == avec))
deallocate(avec, bvec)
if (allocated(error)) exit
end do
end subroutine test_trueloc_empty
subroutine test_trueloc_all(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:)
do ndim = 100, 12000, 100
allocate(avec(-ndim/2:ndim))
call random_number(avec)
avec(trueloc(avec > 0, lbound(avec, 1))) = 0.0
call check(error, all(avec == 0.0))
deallocate(avec)
if (allocated(error)) exit
end do
end subroutine test_trueloc_all
subroutine test_trueloc_where(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:), bvec(:), cvec(:)
real(dp) :: tl, tw
tl = 0.0_dp
tw = 0.0_dp
do ndim = 100, 12000, 100
allocate(avec(ndim))
call random_number(avec)
avec(:) = avec - 0.5
bvec = avec
tl = tl - timing()
bvec(trueloc(bvec > 0)) = 0.0
tl = tl + timing()
cvec = avec
tw = tw - timing()
where(cvec > 0) cvec = 0.0
tw = tw + timing()
call check(error, all(bvec == cvec))
deallocate(avec, bvec, cvec)
if (allocated(error)) exit
end do
call report("trueloc", tl, "where", tw)
end subroutine test_trueloc_where
subroutine test_trueloc_merge(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:), bvec(:), cvec(:)
real(dp) :: tl, tm
tl = 0.0_dp
tm = 0.0_dp
do ndim = 100, 12000, 100
allocate(avec(ndim))
call random_number(avec)
avec(:) = avec - 0.5
bvec = avec
tl = tl - timing()
bvec(trueloc(bvec > 0)) = 0.0
tl = tl + timing()
cvec = avec
tm = tm - timing()
cvec(:) = merge(0.0, cvec, cvec > 0)
tm = tm + timing()
call check(error, all(bvec == cvec))
deallocate(avec, bvec, cvec)
if (allocated(error)) exit
end do
call report("trueloc", tl, "merge", tm)
end subroutine test_trueloc_merge
subroutine test_trueloc_pack(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:), bvec(:), cvec(:)
real(dp) :: tl, tp
tl = 0.0_dp
tp = 0.0_dp
do ndim = 100, 12000, 100
allocate(avec(ndim))
call random_number(avec)
avec(:) = avec - 0.5
bvec = avec
tl = tl - timing()
bvec(trueloc(bvec > 0)) = 0.0
tl = tl + timing()
cvec = avec
tp = tp - timing()
block
integer :: i
cvec(pack([(i, i=1, size(cvec))], cvec > 0)) = 0.0
end block
tp = tp + timing()
call check(error, all(bvec == cvec))
deallocate(avec, bvec, cvec)
if (allocated(error)) exit
end do
call report("trueloc", tl, "pack", tp)
end subroutine test_trueloc_pack
subroutine test_falseloc_empty(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:), bvec(:)
do ndim = 100, 12000, 100
allocate(avec(ndim))
call random_number(avec)
bvec = avec
bvec(falseloc(bvec > 0)) = 0.0
call check(error, all(bvec == avec))
deallocate(avec, bvec)
if (allocated(error)) exit
end do
end subroutine test_falseloc_empty
subroutine test_falseloc_all(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:)
do ndim = 100, 12000, 100
allocate(avec(-ndim/2:ndim))
call random_number(avec)
avec(falseloc(avec < 0, lbound(avec, 1))) = 0.0
call check(error, all(avec == 0.0))
deallocate(avec)
if (allocated(error)) exit
end do
end subroutine test_falseloc_all
subroutine test_falseloc_where(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:), bvec(:), cvec(:)
real(dp) :: tl, tw
tl = 0.0_dp
tw = 0.0_dp
do ndim = 100, 12000, 100
allocate(avec(ndim))
call random_number(avec)
avec(:) = avec - 0.5
bvec = avec
tl = tl - timing()
bvec(falseloc(bvec > 0)) = 0.0
tl = tl + timing()
cvec = avec
tw = tw - timing()
where(.not.(cvec > 0)) cvec = 0.0
tw = tw + timing()
call check(error, all(bvec == cvec))
deallocate(avec, bvec, cvec)
if (allocated(error)) exit
end do
call report("falseloc", tl, "where", tw)
end subroutine test_falseloc_where
subroutine test_falseloc_merge(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:), bvec(:), cvec(:)
real(dp) :: tl, tm
tl = 0.0_dp
tm = 0.0_dp
do ndim = 100, 12000, 100
allocate(avec(ndim))
call random_number(avec)
avec(:) = avec - 0.5
bvec = avec
tl = tl - timing()
bvec(falseloc(bvec > 0)) = 0.0
tl = tl + timing()
cvec = avec
tm = tm - timing()
cvec(:) = merge(cvec, 0.0, cvec > 0)
tm = tm + timing()
call check(error, all(bvec == cvec))
deallocate(avec, bvec, cvec)
if (allocated(error)) exit
end do
call report("falseloc", tl, "merge", tm)
end subroutine test_falseloc_merge
subroutine test_falseloc_pack(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: ndim
real, allocatable :: avec(:), bvec(:), cvec(:)
real(dp) :: tl, tp
tl = 0.0_dp
tp = 0.0_dp
do ndim = 100, 12000, 100
allocate(avec(ndim))
call random_number(avec)
avec(:) = avec - 0.5
bvec = avec
tl = tl - timing()
bvec(falseloc(bvec > 0)) = 0.0
tl = tl + timing()
cvec = avec
tp = tp - timing()
block
integer :: i
cvec(pack([(i, i=1, size(cvec))], cvec < 0)) = 0.0
end block
tp = tp + timing()
call check(error, all(bvec == cvec))
deallocate(avec, bvec, cvec)
if (allocated(error)) exit
end do
call report("falseloc", tl, "pack", tp)
end subroutine test_falseloc_pack
subroutine report(l1, t1, l2, t2)
character(len=*), intent(in) :: l1, l2
real(dp), intent(in) :: t1, t2
character(len=*), parameter :: fmt = "f6.4"
!$omp critical
print '(2x, "[Timing]", *(1x, g0))', &
l1//":", to_string(t1, fmt)//"s", &
l2//":", to_string(t2, fmt)//"s", &
"ratio:", to_string(t1/t2, "f4.1")
!$omp end critical
end subroutine report
function timing() result(time)
real(dp) :: time
integer(i8) :: time_count, time_rate, time_max
call system_clock(time_count, time_rate, time_max)
time = real(time_count, dp)/real(time_rate, dp)
end function timing
end module test_logicalloc
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_logicalloc, only : collect_logicalloc
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("logicalloc", collect_logicalloc) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/array/CMakeLists.txt 0000664 0001750 0001750 00000000024 15135654166 023017 0 ustar alastair alastair ADDTEST(logicalloc)
fortran-lang-stdlib-0ede301/test/specialfunctions/ 0000775 0001750 0001750 00000000000 15135654166 022516 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/specialfunctions/CMakeLists.txt 0000664 0001750 0001750 00000000456 15135654166 025263 0 ustar alastair alastair ### Pre-process: .fpp -> .f90 via Fypp
# Create a list of the files to be preprocessed
set(fppFiles
test_specialfunctions_activations.fypp
test_specialfunctions_gamma.fypp
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(specialfunctions_gamma)
ADDTEST(specialfunctions_activations) fortran-lang-stdlib-0ede301/test/specialfunctions/test_specialfunctions_activations.fypp 0000664 0001750 0001750 00000036754 15135654166 032451 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = [KT for KT in REAL_KINDS_TYPES if KT[0] in ["sp","dp"]]
module test_specialfunctions_activation
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_kinds
use stdlib_specialfunctions
use stdlib_math, only: linspace
implicit none
private
public :: collect_specialfunctions_activation
! use a low accuracy tolerance for the tests as activations should be fast
! and not necessarily accurate
#:for k, t in R_KINDS_TYPES
${t}$, parameter :: tol_${k}$ = 1e-4_${k}$
#:endfor
contains
subroutine collect_specialfunctions_activation(testsuite)
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("gaussian", test_gaussian), &
new_unittest("elu", test_elu), &
new_unittest("relu", test_relu), &
new_unittest("leaky_relu", test_leaky_relu), &
new_unittest("gelu" , test_gelu), &
new_unittest("selu" , test_selu), &
new_unittest("sigmoid", test_sigmoid), &
new_unittest("silu" , test_silu), &
new_unittest("softmax", test_softmax), &
new_unittest("logsoftmax", test_logsoftmax) &
]
end subroutine collect_specialfunctions_activation
subroutine test_gaussian(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(n), y(n), y_ref(n)
x = linspace(-2._${k}$, 2._${k}$, n)
y_ref = exp(-x**2)
y = gaussian( x )
call check(error, norm2(y-y_ref) < n*tol_sp )
if (allocated(error)) return
! Derivative
y_ref = -2._${k}$ * x * exp(-x**2)
y = gaussian_grad( x )
call check(error, norm2(y-y_ref) < n*tol_sp )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_elu(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(n), y(n), y_ref(n), a
x = linspace(-2._${k}$ , 2._${k}$, n)
a = 1.0_${k}$
where(x >= 0._${k}$)
y_ref = x
elsewhere
y_ref = a * (exp(x) - 1._${k}$)
end where
y = elu( x , a )
call check(error, norm2(y-y_ref) < n*tol_sp )
if (allocated(error)) return
! Derivative
where(x >= 0._${k}$)
y_ref = 1.0_${k}$
elsewhere
y_ref = a * exp(x)
end where
y = elu_grad( x , a )
call check(error, norm2(y-y_ref) < n*tol_sp )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_relu(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(n), y(n), y_ref(n)
x = linspace(-2._${k}$ , 2._${k}$, n)
y_ref = max(0._${k}$, x)
y = relu( x )
call check(error, norm2(y-y_ref) < n*tol_sp )
if (allocated(error)) return
! Derivative
where(x > 0._${k}$)
y_ref = 1.0_${k}$
elsewhere
y_ref = 0.0_${k}$
end where
y = relu_grad( x )
call check(error, norm2(y-y_ref) < n*tol_sp )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_selu(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
#:for k, t in R_KINDS_TYPES
block
${t}$, parameter :: scale = 1.0507009873554804934193349852946_${k}$
${t}$, parameter :: alpha = 1.6732632423543772848170429916717_${k}$
${t}$ :: x(n), y(n), y_ref(n)
x = linspace(-2._${k}$, 2._${k}$, n)
where(x >= 0._${k}$)
y_ref = scale * x
elsewhere
y_ref = scale * (alpha * exp(x) - alpha)
end where
y = selu( x )
call check(error, norm2(y-y_ref) < n*tol_${k}$ )
if (allocated(error)) return
! Derivative
where(x >= 0._${k}$)
y_ref = scale
elsewhere
y_ref = scale * alpha * exp(x)
end where
y = selu_grad( x )
call check(error, norm2(y-y_ref) < n*tol_${k}$ )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_gelu(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(n), y(n), y_ref(n)
y_ref = [-0.0455002784729 , -0.093188509345055, -0.148066952824593,&
-0.168328359723091, -0.0915712043643 , 0.130650997161865,&
0.498338282108307, 0.963044226169586, 1.462367057800293,&
1.9544997215271 ]
x = linspace(-2._${k}$, 2._${k}$, n)
y = gelu( x )
call check(error, norm2(y-y_ref) < n*tol_${k}$ )
if (allocated(error)) return
y = gelu_approx( x )
call check(error, norm2(y-y_ref) < n*tol_${k}$ )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_leaky_relu(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(n), y(n), y_ref(n), a
call random_number(x)
a = 0.1_${k}$
where(x>=0._${k}$)
y_ref = x
elsewhere
y_ref = a * x
end where
y = leaky_relu( x , a )
call check(error, norm2(y-y_ref) < n*tol_${k}$ )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_sigmoid(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(n), y(n), y_ref(n)
y_ref = [0.119202919304371, 0.174285307526588, 0.247663781046867,&
0.339243650436401, 0.444671928882599, 0.555328071117401,&
0.660756349563599, 0.752336204051971, 0.825714707374573,&
0.880797028541565]
x = linspace(-2._${k}$, 2._${k}$, n)
y = sigmoid( x )
call check(error, norm2(y-y_ref) < n*tol_${k}$ )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_silu(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(n), y(n), y_ref(n), a
x = linspace(-2._${k}$, 2._${k}$, n)
y_ref = x / (1._${k}$ + exp(-x))
y = silu( x )
call check(error, norm2(y-y_ref) < n*tol_${k}$ )
if (allocated(error)) return
! Derivative
y_ref = (1._${k}$ + exp(x))**2
y_ref = exp(x) * ( x + y_ref ) / y_ref
y = silu_grad( x )
call check(error, norm2(y-y_ref) < n*tol_${k}$ )
if (allocated(error)) return
end block
#:endfor
end subroutine
subroutine test_softmax(error)
type(error_type), allocatable, intent(out) :: error
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(3,3,3), y(3,3,3), y_ref(3,3,3)
x = reshape( [ 0.82192878, 0.76998032, 0.98611263,&
0.8621334 , 0.65358045, 0.26387113,&
0.12743663, 0.35237132, 0.23801647,&
0.69773567, 0.40568874, 0.44789482,&
0.42930753, 0.49579193, 0.53139985,&
0.03035799, 0.65293157, 0.47613957,&
0.21088634, 0.9356926 , 0.0991312 ,&
0.46070181, 0.02943479, 0.17557538,&
0.10541313, 0.33946349, 0.34804323 ] ,[3,3,3] )
!> softmax on dim = 1
y = softmax(x,dim=1)
y_ref = reshape( [ 0.319712639, 0.303528070, 0.376759291,&
0.423455358, 0.343743294, 0.232801422,&
0.296809316, 0.371676773, 0.331513911,&
0.395936400, 0.295658976, 0.308404684,&
0.314838648, 0.336482018, 0.348679334,&
0.225966826, 0.421138495, 0.352894694,&
0.252614945, 0.521480858, 0.225904226,&
0.416388273, 0.270521373, 0.313090324,&
0.282621205, 0.357150704, 0.360228121 ] ,[3,3,3] )
call check(error, norm2(y-y_ref) < tol_${k}$ )
if (allocated(error)) return
!> softmax on dim = 2
y = softmax(x,dim=2)
y_ref = reshape( [ 0.393646270, 0.392350882, 0.510482967,&
0.409795105, 0.349239051, 0.247922391,&
0.196558580, 0.258410037, 0.241594598,&
0.439052343, 0.296315849, 0.320951223,&
0.335690796, 0.324254662, 0.348903090,&
0.225256786, 0.379429489, 0.330145657,&
0.314101219, 0.511530280, 0.297435701,&
0.403239518, 0.206675291, 0.321064562,&
0.282659233, 0.281794399, 0.381499708 ] ,[3,3,3] )
call check(error, norm2(y-y_ref) < tol_${k}$ )
if (allocated(error)) return
!> softmax on dim = 3
y = softmax(x,dim=3)
y_ref = reshape( [ 0.412202179, 0.347835541, 0.501081109,&
0.431399941, 0.418453932, 0.310344934,&
0.346536130, 0.299599379, 0.295405835,&
0.364060789, 0.241637364, 0.292525023,&
0.279837668, 0.357372403, 0.405537367,&
0.314476222, 0.404643506, 0.374830246,&
0.223737061, 0.410527140, 0.206393898,&
0.288762331, 0.224173695, 0.284117699,&
0.338987619, 0.295757085, 0.329763889 ] ,[3,3,3] )
call check(error, norm2(y-y_ref) < tol_${k}$ )
if (allocated(error)) return
end block
#:endfor
end subroutine test_softmax
subroutine test_logsoftmax(error)
type(error_type), allocatable, intent(out) :: error
#:for k, t in R_KINDS_TYPES
block
${t}$ :: x(3,3,3), y(3,3,3), y_ref(3,3,3)
x = reshape( [ 0.755308866500854,-0.789980888366699, 0.88806813955307 ,&
-1.210636496543884, 0.746919095516205, 0.177668794989586,&
0.540819883346558, 0.291532933712006,-0.324642956256866,&
1.94184136390686 , 0.951070547103882,-2.303410291671753,&
0.59752631187439 , 1.189722180366516, 1.401878595352173,&
-0.262732744216919, 0.421907186508179,-0.200457707047462,&
-0.702468574047089, 0.153426378965378, 0.330110251903534,&
-1.16956090927124 ,-0.845042765140533,-1.364316940307617,&
-1.679381608963013,-1.497506022453308,-1.194215059280396 ] ,[3,3,3] )
!> logsoftmax on dim = 1
y = logsoftmax(x,dim=1)
y_ref = reshape( [ -0.856636286,-2.40192604,-0.723877013,&
-2.49238253,-0.534826934,-1.10407722 ,&
-0.788554132,-1.03784108,-1.65401697 ,&
-0.326149583,-1.31692040,-4.57140112 ,&
-1.61804128,-1.02584541,-0.813688993 ,&
-1.39805317,-0.713413179,-1.33577800 ,&
-1.81836534,-0.962470412,-0.785786569,&
-1.16514850,-0.840630412,-1.35990453 ,&
-1.34127355,-1.15939808,-0.856107056 ],[3,3,3] )
!> logsoftmax on dim = 2
y = logsoftmax(x,dim=2)
y_ref = reshape( [ -0.666278005,-2.15167999, -0.581566215,&
-2.63222337 ,-0.614779949,-1.29196548 ,&
-0.880766988,-1.07016611,-1.79427731 ,&
-0.315551817,-1.05034387,-3.90906072 ,&
-1.65986681 ,-0.811692238,-0.203771874,&
-2.52012587 ,-1.57950723 ,-1.80610812 ,&
-0.694792688,-0.444887042,-0.337523341,&
-1.16188502 ,-1.44335616 ,-2.03195047 ,&
-1.67170572 ,-2.09581947 ,-1.86184871 ],[3,3,3] )
call check(error, norm2(y-y_ref) < tol_${k}$ )
if (allocated(error)) return
!> logsoftmax on dim = 3
y = logsoftmax(x,dim=3)
y_ref = reshape( [ -1.50595474 , -2.22700500 ,-0.478398114,&
-2.09693313 , -1.01544499 ,-1.52940571 ,&
-0.442325860, -0.835677147,-0.936625183,&
-0.319422185, -0.485953659,-3.66987658 ,&
-0.288770229, -0.572641909,-0.305195898,&
-1.24587846 , -0.705302894,-0.812439919,&
-2.96373224 , -1.28359783 ,-1.03635597 ,&
-2.05585742 , -2.60740685 ,-3.07139134 ,&
-2.66252732 , -2.62471604 ,-1.80619729 ],[3,3,3] )
call check(error, norm2(y-y_ref) < tol_${k}$ )
if (allocated(error)) return
end block
#:endfor
end subroutine test_logsoftmax
end module test_specialfunctions_activation
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_specialfunctions_activation, only : collect_specialfunctions_activation
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [new_testsuite("activation functions", &
collect_specialfunctions_activation)]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester fortran-lang-stdlib-0ede301/test/specialfunctions/test_specialfunctions_gamma.fypp 0000664 0001750 0001750 00000056537 15135654166 031210 0 ustar alastair alastair #:include "common.fypp"
#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set IDX_CMPLX_KINDS_TYPES = [(i, CMPLX_KINDS[i], CMPLX_TYPES[i], CMPLX_INIT[i]) for i in range(len(CMPLX_KINDS))]
#:set IDX_REAL_KINDS_TYPES = [(i, REAL_KINDS[i], REAL_TYPES[i], REAL_INIT[i]) for i in range(len(REAL_KINDS))]
module test_specialfunctions_gamma
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64
use stdlib_error, only: state_type, STDLIB_VALUE_ERROR
use stdlib_specialfunctions_gamma, only: gamma, log_gamma, log_factorial, &
lower_incomplete_gamma, &
upper_incomplete_gamma, &
log_lower_incomplete_gamma, &
log_upper_incomplete_gamma, &
regularized_gamma_p, &
regularized_gamma_q
implicit none
private
public :: collect_specialfunctions_gamma
#:for k1, t1 in REAL_KINDS_TYPES
${t1}$, parameter :: tol_${k1}$ = sqrt(epsilon(1.0_${k1}$))
#:endfor
contains
subroutine collect_specialfunctions_gamma(testsuite)
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("log_factorial_iint8", test_logfact_iint8) &
#:for k1, t1 in INT_KINDS_TYPES
, new_unittest("log_factorial_${t1[0]}$${k1}$", &
test_logfact_${t1[0]}$${k1}$) &
#:endfor
#:for k1, t1 in CI_KINDS_TYPES[:-1]
, new_unittest("gamma_${t1[0]}$${k1}$", &
test_gamma_${t1[0]}$${k1}$) &
, new_unittest("log_gamma_${t1[0]}$${k1}$", &
test_loggamma_${t1[0]}$${k1}$) &
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
, new_unittest("lower_incomplete_gamma_${t1[0]}$${k1}$${k2}$", &
test_lincgamma_${t1[0]}$${k1}$${k2}$) &
, new_unittest("log_lower_incomplete_gamma_${t1[0]}$${k1}$${k2}$", &
test_log_lincgamma_${t1[0]}$${k1}$${k2}$) &
, new_unittest("upper_incomplete_gamma_${t1[0]}$${k1}$${k2}$", &
test_uincgamma_${t1[0]}$${k1}$${k2}$) &
, new_unittest("log_upper_incomplete_gamma_${t1[0]}$${k1}$${k2}$", &
test_log_uincgamma_${t1[0]}$${k1}$${k2}$) &
, new_unittest("regularized_gamma_p_${t1[0]}$${k1}$${k2}$", &
test_gamma_p_${t1[0]}$${k1}$${k2}$) &
, new_unittest("regularized_gamma_q_${t1[0]}$${k1}$${k2}$", &
test_gamma_q_${t1[0]}$${k1}$${k2}$) &
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
, new_unittest("lower_incomplete_gamma_${t1[0]}$${k1}$", &
test_lincgamma_${t1[0]}$${k1}$) &
, new_unittest("log_lower_incomplete_gamma_${t1[0]}$${k1}$", &
test_log_lincgamma_${t1[0]}$${k1}$) &
, new_unittest("upper_incomplete_gamma_${t1[0]}$${k1}$", &
test_uincgamma_${t1[0]}$${k1}$) &
, new_unittest("log_upper_incomplete_gamma_${t1[0]}$${k1}$", &
test_log_uincgamma_${t1[0]}$${k1}$) &
, new_unittest("regularized_gamma_p_${t1[0]}$${k1}$", &
test_gamma_p_${t1[0]}$${k1}$) &
, new_unittest("regularized_gamma_q_${t1[0]}$${k1}$", &
test_gamma_q_${t1[0]}$${k1}$) &
#:endfor
]
end subroutine collect_specialfunctions_gamma
#:for k1, t1 in INT_KINDS_TYPES
#:set k2, t2 = REAL_KINDS[-2], REAL_TYPES[-2]
subroutine test_logfact_${t1[0]}$${k1}$(error)
type(error_type), allocatable, intent(out) :: error
integer :: i
integer, parameter :: xtest(*) = [0,1,2,4,5,7,12,20,100,500,7000,90000]
${t2}$, parameter :: res(*) = [0.0_${k2}$, &
0.0_${k2}$, &
0.69314718055994_${k2}$, &
3.17805383034794_${k2}$, &
4.78749174278204_${k2}$, &
8.52516136106541_${k2}$, &
1.998721449566e1_${k2}$, &
4.233561646075e1_${k2}$, &
3.637393755555e2_${k2}$, &
2.611330458460e3_${k2}$, &
5.498100377941e4_${k2}$, &
9.366874681600e5_${k2}$]
${t1}$, parameter :: x(*) = pack(xtest, xtest 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/specialfunctions/Makefile.manual 0000664 0001750 0001750 00000000306 15135654166 025431 0 ustar alastair alastair SRCFYPP = \
test_specialfunctions_gamma.fypp
SRCGEN = $(SRCFYPP:.fypp=.f90)
$(SRCGEN): %.f90: %.fypp ../../common.fypp
fypp -I../.. $(FYPPFLAGS) $< $@
include ../Makefile.manual.test.mk
fortran-lang-stdlib-0ede301/test/io/ 0000775 0001750 0001750 00000000000 15135654166 017554 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/io/test_loadtxt_qp.fypp 0000664 0001750 0001750 00000007205 15135654166 023676 0 ustar alastair alastair #:include "common.fypp"
module test_loadtxt_qp
use stdlib_kinds, only: qp
use stdlib_io, only: loadtxt, savetxt
use testdrive, only: new_unittest, unittest_type, error_type, check, skip_test
implicit none
private
public :: collect_loadtxt_qp
contains
!> Collect all exported unit tests
subroutine collect_loadtxt_qp(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("loadtxt_qp", test_loadtxt_qp_), &
new_unittest("loadtxt_qp_huge", test_loadtxt_qp_huge), &
new_unittest("loadtxt_qp_tiny", test_loadtxt_qp_tiny) &
]
end subroutine collect_loadtxt_qp
subroutine test_loadtxt_qp_(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
real(qp), allocatable :: input(:,:), expected(:,:)
integer :: n
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 100
call random_number(input)
input = input - 0.5
call savetxt('test_qp.txt', input)
call loadtxt('test_qp.txt', expected)
call check(error, all(input == expected))
if (allocated(error)) return
end do
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_loadtxt_qp_
subroutine test_loadtxt_qp_huge(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
real(qp), allocatable :: input(:,:), expected(:,:)
integer :: n
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(input)
input = (input - 0.5) * huge(input)
call savetxt('test_qp_huge.txt', input)
call loadtxt('test_qp_huge.txt', expected)
call check(error, all(input == expected))
if (allocated(error)) return
end do
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_loadtxt_qp_huge
subroutine test_loadtxt_qp_tiny(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
real(qp), allocatable :: input(:,:), expected(:,:)
integer :: n
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(input)
input = (input - 0.5) * tiny(input)
call savetxt('test_qp_tiny.txt', input)
call loadtxt('test_qp_tiny.txt', expected)
call check(error, all(input == expected))
if (allocated(error)) return
end do
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_loadtxt_qp_tiny
end module test_loadtxt_qp
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_loadtxt_qp, only : collect_loadtxt_qp
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("loadtxt_qp", collect_loadtxt_qp) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/io/test_npy.f90 0000664 0001750 0001750 00000057650 15135654166 021756 0 ustar alastair alastair module test_npy
use stdlib_kinds, only : int8, int16, int32, int64, sp, dp
use stdlib_io_npy, only : save_npy, load_npy
use testdrive, only : new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_npy
contains
!> Collect all exported unit tests
subroutine collect_npy(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("read-rdp-r2", test_read_rdp_rank2), &
new_unittest("read-rdp-r3", test_read_rdp_rank3), &
new_unittest("read-rsp-r1", test_read_rsp_rank1), &
new_unittest("read-rsp-r2", test_read_rsp_rank2), &
new_unittest("write-rdp-r2", test_write_rdp_rank2), &
new_unittest("write-rsp-r2", test_write_rsp_rank2), &
new_unittest("write-i2-r4", test_write_int16_rank4), &
new_unittest("invalid-magic-number", test_invalid_magic_number, should_fail=.true.), &
new_unittest("invalid-magic-string", test_invalid_magic_string, should_fail=.true.), &
new_unittest("invalid-major-version", test_invalid_major_version, should_fail=.true.), &
new_unittest("invalid-minor-version", test_invalid_minor_version, should_fail=.true.), &
new_unittest("invalid-header-len", test_invalid_header_len, should_fail=.true.), &
new_unittest("invalid-nul-byte", test_invalid_nul_byte, should_fail=.true.), &
new_unittest("invalid-key", test_invalid_key, should_fail=.true.), &
new_unittest("invalid-comma", test_invalid_comma, should_fail=.true.), &
new_unittest("invalid-string", test_invalid_string, should_fail=.true.), &
new_unittest("duplicate-descr", test_duplicate_descr, should_fail=.true.), &
new_unittest("missing-descr", test_missing_descr, should_fail=.true.), &
new_unittest("missing-fortran_order", test_missing_fortran_order, should_fail=.true.), &
new_unittest("missing-shape", test_missing_shape, should_fail=.true.), &
new_unittest("iomsg-deallocated", test_iomsg_deallocated) &
]
end subroutine collect_npy
subroutine test_read_rdp_rank2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr':' Error handling
type(error_type), allocatable, intent(out) :: error
integer :: stat
character(len=*), parameter :: filename = ".test-rdp-r2-rt.npy"
real(dp), allocatable :: input(:, :), output(:, :)
allocate(input(10, 4))
call random_number(input)
call save_npy(filename, input, stat)
call check(error, stat, "Writing of npy file failed")
if (allocated(error)) return
call load_npy(filename, output, stat)
call delete_file(filename)
call check(error, stat, "Reading of npy file failed")
if (allocated(error)) return
call check(error, size(output), size(input))
if (allocated(error)) return
call check(error, any(abs(output - input) <= epsilon(1.0_dp)), &
"Precision loss when rereading array")
end subroutine test_write_rdp_rank2
subroutine test_write_rsp_rank2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: stat
character(len=*), parameter :: filename = ".test-rsp-r2-rt.npy"
real(sp), allocatable :: input(:, :), output(:, :)
allocate(input(12, 5))
call random_number(input)
call save_npy(filename, input, stat)
call check(error, stat, "Writing of npy file failed")
if (allocated(error)) return
call load_npy(filename, output, stat)
call delete_file(filename)
call check(error, stat, "Reading of npy file failed")
if (allocated(error)) return
call check(error, size(output), size(input))
if (allocated(error)) return
call check(error, any(abs(output - input) <= epsilon(1.0_dp)), &
"Precision loss when rereading array")
end subroutine test_write_rsp_rank2
subroutine test_write_int16_rank4(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: stat, i
character(len=*), parameter :: filename = ".test-i2-r4-rt.npy"
integer(int16), allocatable :: input(:, :, :, :), output(:, :, :, :)
input = reshape([(i*(i+1)/2, i = 1, 40)], [2, 5, 2, 2])
call save_npy(filename, input, stat)
call check(error, stat, "Writing of npy file failed")
if (allocated(error)) return
call load_npy(filename, output, stat)
call delete_file(filename)
call check(error, stat, "Reading of npy file failed")
if (allocated(error)) return
call check(error, size(output), size(input))
if (allocated(error)) return
call check(error, all(abs(output - input) == 0), &
"Precision loss when rereading array")
end subroutine test_write_int16_rank4
subroutine test_invalid_magic_number(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'fortran_order': True,, 'shape': (10, 4, ), 'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'fortran_order': True, 'shape': (10, 4, ), } " // &
char(10)
character(len=*), parameter :: header = &
char(int(z"93")) // "NUMPY" // char(1) // char(0) // &
char(len(dict)) // char(0) // dict
integer :: io, stat
character(len=:), allocatable :: msg
character(len=*), parameter :: filename = ".test-missing-descr.npy"
real(dp), allocatable :: array(:, :)
open(newunit=io, file=filename, form="unformatted", access="stream")
write(io) header
write(io) spread(0.0_dp, 1, 40)
close(io)
call load_npy(filename, array, stat, msg)
call delete_file(filename)
call check(error, stat, msg)
end subroutine test_missing_descr
subroutine test_missing_fortran_order(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: dict = &
"{'fortran_order': True, 'descr': ' Error handling
type(error_type), allocatable, intent(out) :: error
integer :: stat
character(len=:), allocatable :: msg
character(len=*), parameter :: filename = ".test-iomsg-deallocated.npy"
real(sp), allocatable :: input(:, :)
msg = "This message should be deallocated."
allocate(input(12, 5))
call random_number(input)
call save_npy(filename, input, stat, msg)
call delete_file(filename)
call check(error,.not. allocated(msg), "Message wrongly allocated.")
end subroutine
subroutine delete_file(filename)
character(len=*), intent(in) :: filename
integer :: io
open(newunit=io, file=filename)
close(io, status="delete")
end subroutine delete_file
end module test_npy
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_npy, only : collect_npy
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("npy", collect_npy) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/io/test_open.f90 0000664 0001750 0001750 00000011113 15135654166 022071 0 ustar alastair alastair module test_open
use stdlib_io, only: open
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_open
contains
!> Collect all exported unit tests
subroutine collect_open(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("io_read_write_text", test_io_read_write_text), &
new_unittest("io_read_write_stream", test_io_read_write_stream), &
new_unittest("io_open_error_flag", test_io_open_error_flag) &
]
end subroutine collect_open
function get_outpath() result(outpath)
integer :: ierr
character(256) :: argv
character(:), allocatable :: outpath
call get_command_argument(1, argv, status=ierr)
if (ierr == 0) then
outpath = trim(argv)
else
outpath = '.'
end if
end function get_outpath
subroutine test_io_read_write_text(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(:), allocatable :: filename
integer :: u, a(3)
! Text file
filename = get_outpath() // "/io_open.dat"
! Test mode "w"
u = open(filename, "w")
write(u, *) 1, 2, 3
close(u)
! Test mode "r"
u = open(filename, "r")
read(u, *) a
call check(error, all(a == [1, 2, 3]))
close(u)
if (allocated(error)) return
! Test mode "a"
u = open(filename, "a")
write(u, *) 4, 5, 6
close(u)
u = open(filename, "r")
read(u, *) a
call check(error, all(a == [1, 2, 3]))
read(u, *) a
call check(error, all(a == [4, 5, 6]))
close(u)
if (allocated(error)) return
end subroutine test_io_read_write_text
subroutine test_io_read_write_stream(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(:), allocatable :: filename
integer :: u, a(3)
! Stream file
filename = get_outpath() // "/io_open.stream"
! Test mode "w"
u = open(filename, "wb")
write(u) 1, 2, 3
close(u)
! Test mode "r"
u = open(filename, "rb")
read(u) a
call check(error, all(a == [1, 2, 3]))
close(u)
if (allocated(error)) return
! Test mode "a"
u = open(filename, "ab")
write(u) 4, 5, 6
close(u)
u = open(filename, "rb")
read(u) a
call check(error, all(a == [1, 2, 3]))
read(u) a
if (allocated(error)) return
call check(error, all(a == [4, 5, 6]))
close(u)
if (allocated(error)) return
end subroutine test_io_read_write_stream
subroutine test_io_open_error_flag(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(:), allocatable :: filename
integer :: ierr, u
filename = get_outpath() // "/io_open.stream"
! Write to file first to ensure that it exists
u = open(filename, "wb")
write(u) 1, 2, 3
close(u)
u = open(filename, "rb", ierr)
call check(error, ierr == 0)
if (ierr == 0) close(u)
if (allocated(error)) return
u = open(filename, "ab", ierr)
call check(error, ierr == 0)
if (ierr == 0) close(u)
if (allocated(error)) return
filename = get_outpath() // "/does_not_exist.error"
u = open(filename, "a", ierr)
call check(error, ierr /= 0)
if (allocated(error)) return
u = open(filename, "r", ierr)
call check(error, ierr /= 0)
if (allocated(error)) return
end subroutine test_io_open_error_flag
end module test_open
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_open, only : collect_open
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("open", collect_open) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/io/test_savetxt_qp.fypp 0000664 0001750 0001750 00000007247 15135654166 023723 0 ustar alastair alastair #:include "common.fypp"
module test_savetxt_qp
use stdlib_kinds, only: qp
use stdlib_io, only: loadtxt, savetxt
use testdrive, only: new_unittest, unittest_type, error_type, check, skip_test
implicit none
private
public :: collect_savetxt_qp
contains
!> Collect all exported unit tests
subroutine collect_savetxt_qp(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("rqp", test_rqp), &
new_unittest("cqp", test_cqp) &
]
end subroutine collect_savetxt_qp
function get_outpath() result(outpath)
integer :: ierr
character(256) :: argv
character(:), allocatable :: outpath
call get_command_argument(1, argv, status=ierr)
if (ierr == 0) then
outpath = trim(argv)
else
outpath = '.'
end if
end function get_outpath
subroutine test_rqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
real(qp) :: d(3, 2), e(2, 3)
real(qp), allocatable :: d2(:, :)
character(:), allocatable :: outpath
outpath = get_outpath() // "/tmp_test_rqp.dat"
d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
call savetxt(outpath, d)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [3, 2]))
if (allocated(error)) return
call check(error, all(d == d2))
if (allocated(error)) return
e = reshape([1, 2, 3, 4, 5, 6], [2, 3])
call savetxt(outpath, e)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [2, 3]))
if (allocated(error)) return
call check(error, all(e == d2))
if (allocated(error)) return
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_rqp
subroutine test_cqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
complex(qp) :: d(3, 2), e(2, 3)
complex(qp), allocatable :: d2(:, :)
character(:), allocatable :: outpath
outpath = get_outpath() // "/tmp_test_cqp.dat"
d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
call savetxt(outpath, d)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [3, 2]))
if (allocated(error)) return
call check(error, all(d == d2))
if (allocated(error)) return
e = reshape([1, 2, 3, 4, 5, 6], [2, 3])
call savetxt(outpath, e)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [2, 3]))
if (allocated(error)) return
call check(error, all(e == d2))
if (allocated(error)) return
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_cqp
end module test_savetxt_qp
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_savetxt_qp, only : collect_savetxt_qp
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("savetxt_qp", collect_savetxt_qp) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/io/test_savetxt.f90 0000664 0001750 0001750 00000014434 15135654166 022637 0 ustar alastair alastair module test_savetxt
use stdlib_kinds, only: int32, sp, dp
use stdlib_io, only: loadtxt, savetxt
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_savetxt
contains
!> Collect all exported unit tests
subroutine collect_savetxt(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("iint32", test_iint32), &
new_unittest("rsp", test_rsp), &
new_unittest("rdp", test_rdp), &
new_unittest("csp", test_csp), &
new_unittest("cdp", test_cdp) &
]
end subroutine collect_savetxt
function get_outpath() result(outpath)
integer :: ierr
character(256) :: argv
character(:), allocatable :: outpath
call get_command_argument(1, argv, status=ierr)
if (ierr == 0) then
outpath = trim(argv)
else
outpath = '.'
end if
end function get_outpath
subroutine test_iint32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int32) :: d(3, 2), e(2, 3)
integer(int32), allocatable :: d2(:, :)
character(:), allocatable :: outpath
outpath = get_outpath() // "/tmp_test_iint32.dat"
d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
call savetxt(outpath, d)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [3, 2]))
if (allocated(error)) return
call check(error, all(d == d2))
if (allocated(error)) return
e = reshape([1, 2, 3, 4, 5, 6], [2, 3])
call savetxt(outpath, e)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [2, 3]))
if (allocated(error)) return
call check(error, all(e == d2))
if (allocated(error)) return
end subroutine
subroutine test_rsp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(sp) :: d(3, 2), e(2, 3)
real(sp), allocatable :: d2(:, :)
character(:), allocatable :: outpath
outpath = get_outpath() // "/tmp_test_rsp.dat"
d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
call savetxt(outpath, d)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [3, 2]))
if (allocated(error)) return
call check(error, all(d == d2))
if (allocated(error)) return
e = reshape([1, 2, 3, 4, 5, 6], [2, 3])
call savetxt(outpath, e)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [2, 3]))
if (allocated(error)) return
call check(error, all(e == d2))
if (allocated(error)) return
end subroutine test_rsp
subroutine test_rdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp) :: d(3, 2), e(2, 3)
real(dp), allocatable :: d2(:, :)
character(:), allocatable :: outpath
outpath = get_outpath() // "/tmp_test_rdp.dat"
d = reshape([1, 2, 3, 4, 5, 6], [3, 2])
call savetxt(outpath, d)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [3, 2]))
if (allocated(error)) return
call check(error, all(d == d2))
if (allocated(error)) return
e = reshape([1, 2, 3, 4, 5, 6], [2, 3])
call savetxt(outpath, e)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [2, 3]))
if (allocated(error)) return
call check(error, all(e == d2))
if (allocated(error)) return
end subroutine test_rdp
subroutine test_csp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(sp) :: d(3, 2), e(2, 3)
complex(sp), allocatable :: d2(:, :)
character(:), allocatable :: outpath
outpath = get_outpath() // "/tmp_test_csp.dat"
d = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [3, 2])
call savetxt(outpath, d)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [3, 2]))
if (allocated(error)) return
call check(error, all(d == d2))
if (allocated(error)) return
e = cmplx(1, 1,kind=sp)* reshape([1, 2, 3, 4, 5, 6], [2, 3])
call savetxt(outpath, e)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [2, 3]))
if (allocated(error)) return
call check(error, all(e == d2))
if (allocated(error)) return
end subroutine test_csp
subroutine test_cdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(dp) :: d(3, 2), e(2, 3)
complex(dp), allocatable :: d2(:, :)
character(:), allocatable :: outpath
outpath = get_outpath() // "/tmp_test_cdp.dat"
d = cmplx(1._dp, 1._dp,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [3, 2])
call savetxt(outpath, d)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [3, 2]))
if (allocated(error)) return
call check(error, all(d == d2))
if (allocated(error)) return
e = cmplx(1, 1,kind=dp)* reshape([1, 2, 3, 4, 5, 6], [2, 3])
call savetxt(outpath, e)
call loadtxt(outpath, d2)
call check(error, all(shape(d2) == [2, 3]))
if (allocated(error)) return
call check(error, all(e == d2))
if (allocated(error)) return
end subroutine test_cdp
end module test_savetxt
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_savetxt, only : collect_savetxt
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("savetxt", collect_savetxt) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/io/CMakeLists.txt 0000664 0001750 0001750 00000000620 15135654166 022312 0 ustar alastair alastair set(
fppFiles
"test_loadtxt_qp.fypp"
"test_savetxt_qp.fypp"
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(loadtxt)
ADDTEST(savetxt)
ADDTEST(loadtxt_qp)
ADDTEST(savetxt_qp)
set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision)
set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision)
ADDTEST(get_line)
ADDTEST(npy)
ADDTEST(open)
ADDTEST(parse_mode)
fortran-lang-stdlib-0ede301/test/io/test_parse_mode.f90 0000664 0001750 0001750 00000012421 15135654166 023251 0 ustar alastair alastair module test_parse_mode
use stdlib_ascii, only: reverse
use stdlib_io, only: parse_mode
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_parse_mode
character(3), parameter :: parse_modes_input(*) = [ &
" ", &
"r ", "w ", "a ", "x ", &
"rt ", "wt ", "at ", "xt ", &
"rb ", "wb ", "ab ", "xb ", &
"r+ ", "w+ ", "a+ ", "x+ ", &
"r+t", "w+t", "a+t", "x+t", &
"r+b", "w+b", "a+b", "x+b" &
]
character(3), parameter :: parse_modes_expected(*) = [ &
"r t", &
"r t", "w t", "a t", "x t", &
"r t", "w t", "a t", "x t", &
"r b", "w b", "a b", "x b", &
"r+t", "w+t", "a+t", "x+t", &
"r+t", "w+t", "a+t", "x+t", &
"r+b", "w+b", "a+b", "x+b" &
]
contains
!> Collect all exported unit tests
subroutine collect_parse_mode(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("parse_mode_expected_order", test_parse_mode_expected_order), &
new_unittest("parse_mode_reverse_order", test_parse_mode_reverse_order), &
new_unittest("parse_mode_random_order", test_parse_mode_random_order) &
!FIXME Is it possible to run tests with error stop?
!new_unittest("parse_mode_always_fail", test_parse_mode_always_fail) &
]
end subroutine collect_parse_mode
subroutine test_parse_mode_expected_order(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: n
do n = 1, size(parse_modes_input)
call check(error, parse_mode(trim(parse_modes_input(n))) == &
parse_modes_expected(n))
if (allocated(error)) return
end do
end subroutine test_parse_mode_expected_order
subroutine test_parse_mode_reverse_order(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: n
do n = 1, size(parse_modes_input)
call check(error, &
parse_mode(trim(reverse(parse_modes_input(n)))) == &
parse_modes_expected(n))
if (allocated(error)) return
end do
end subroutine test_parse_mode_reverse_order
subroutine test_parse_mode_random_order(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, parse_mode("t r") == "r t")
if (allocated(error)) return
call check(error, parse_mode(" tw ") == "w t")
if (allocated(error)) return
call check(error, parse_mode("ta ") == "a t")
if (allocated(error)) return
call check(error, parse_mode(" t x ") == "x t")
if (allocated(error)) return
call check(error, parse_mode("+ r ") == "r+t")
if (allocated(error)) return
call check(error, parse_mode("w +") == "w+t")
if (allocated(error)) return
call check(error, parse_mode(" a+") == "a+t")
if (allocated(error)) return
call check(error, parse_mode(" x+ t ") == "x+t")
if (allocated(error)) return
call check(error, parse_mode("tr+ ") == "r+t")
if (allocated(error)) return
call check(error, parse_mode("wt + ") == "w+t")
if (allocated(error)) return
call check(error, parse_mode("a + t") == "a+t")
if (allocated(error)) return
call check(error, parse_mode(" xt + ") == "x+t")
if (allocated(error)) return
call check(error, parse_mode(" + t") == "r+t")
if (allocated(error)) return
call check(error, parse_mode(" +w b") == "w+b")
if (allocated(error)) return
call check(error, parse_mode("a + b") == "a+b")
if (allocated(error)) return
call check(error, parse_mode(" b + x ") == "x+b")
if (allocated(error)) return
end subroutine test_parse_mode_random_order
subroutine test_parse_mode_always_fail(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, parse_mode("r+w") /= "r t")
if (allocated(error)) return
call check(error, parse_mode("tt") /= "r t")
if (allocated(error)) return
call check(error, parse_mode("bt") /= "r t")
if (allocated(error)) return
end subroutine test_parse_mode_always_fail
end module test_parse_mode
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_parse_mode, only : collect_parse_mode
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("parse_mode", collect_parse_mode) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/io/test_get_line.f90 0000664 0001750 0001750 00000017173 15135654166 022732 0 ustar alastair alastair module test_get_line
use stdlib_io, only : get_line, get_file
use stdlib_error, only: state_type
use stdlib_string_type, only : string_type, len, len_trim
use testdrive, only : new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_get_line
contains
!> Collect all exported unit tests
subroutine collect_get_line(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("read-char", test_read_char), &
new_unittest("read-string", test_read_string), &
new_unittest("pad-no", test_pad_no), &
new_unittest("iostat-end", test_iostat_end), &
new_unittest("closed-unit", test_closed_unit, should_fail=.true.), &
new_unittest("no-unit", test_no_unit, should_fail=.true.), &
new_unittest("get_file-no", test_get_file_missing), &
new_unittest("get_file-empty", test_get_file_empty), &
new_unittest("get_file-non-empty", test_get_file_non_empty) &
]
end subroutine collect_get_line
subroutine test_read_char(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: io, i, stat
character(len=:), allocatable :: line
open(newunit=io, status="scratch")
write(io, "(a)") repeat("abc", 10), repeat("def", 100), repeat("ghi", 1000)
rewind(io)
do i = 1, 3
call get_line(io, line, stat)
call check(error, stat)
if (allocated(error)) exit
call check(error, len(line), 3*10**i)
if (allocated(error)) exit
end do
close(io)
end subroutine test_read_char
subroutine test_read_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: io, i, stat
type(string_type) :: line
open(newunit=io, status="scratch")
write(io, "(a)") repeat("abc", 10), repeat("def", 100), repeat("ghi", 1000)
rewind(io)
do i = 1, 3
call get_line(io, line, stat)
call check(error, stat)
if (allocated(error)) exit
call check(error, len(line), 3*10**i)
if (allocated(error)) exit
end do
close(io)
end subroutine test_read_string
subroutine test_pad_no(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: io, i, stat
character(len=:), allocatable :: line
open(newunit=io, status="scratch", pad="no")
write(io, "(a)") repeat("abc", 10), repeat("def", 100), repeat("ghi", 1000)
rewind(io)
do i = 1, 3
call get_line(io, line, stat)
call check(error, stat)
if (allocated(error)) exit
call check(error, len(line), 3*10**i)
if (allocated(error)) exit
end do
close(io)
end subroutine test_pad_no
subroutine test_iostat_end(error)
use, intrinsic :: iso_fortran_env, only : iostat_end
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: io, i, stat
character(len=:), allocatable :: line
open(newunit=io, status="scratch")
write(io, "(a)") repeat("abc", 10), repeat("def", 100), repeat("ghi", 1000)
rewind(io)
do i = 1, 3
call get_line(io, line, stat)
call check(error, stat)
if (allocated(error)) exit
call check(error, len(line), 3*10**i)
if (allocated(error)) exit
end do
if (.not.allocated(error)) then
call get_line(io, line, stat)
call check(error, stat, iostat_end)
end if
close(io)
end subroutine test_iostat_end
subroutine test_closed_unit(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: io, stat
character(len=:), allocatable :: line, msg
open(newunit=io, status="scratch")
close(io)
call get_line(io, line, stat, msg)
call check(error, stat, msg)
end subroutine test_closed_unit
subroutine test_no_unit(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: io, stat
character(len=:), allocatable :: line, msg
io = -1
call get_line(io, line, stat, msg)
call check(error, stat, msg)
end subroutine test_no_unit
subroutine test_get_file_missing(error)
!> Test for a missing file.
type(error_type), allocatable, intent(out) :: error
type(string_type) :: filecontents
type(state_type) :: err
call get_file("nonexistent_file.txt", fileContents, err)
! Check that an error was returned
call check(error, err%error(), "Error not returned on a missing file")
if (allocated(error)) return
end subroutine test_get_file_missing
subroutine test_get_file_empty(error)
!> Test for an empty file.
type(error_type), allocatable, intent(out) :: error
integer :: ios
character(len=:), allocatable :: filename
type(string_type) :: filecontents
type(state_type) :: err
! Get a temporary file name
filename = "test_get_file_empty.txt"
! Create an empty file
open(newunit=ios, file=filename, action="write", form="formatted", access="sequential")
close(ios)
! Read and delete it
call get_file(filename, filecontents, err, delete=.true.)
call check(error, err%ok(), "Should not return error reading an empty file")
if (allocated(error)) return
call check(error, len_trim(filecontents) == 0, "String from empty file should be empty")
if (allocated(error)) return
end subroutine test_get_file_empty
subroutine test_get_file_non_empty(error)
!> Test for a non-empty file.
type(error_type), allocatable, intent(out) :: error
integer :: ios
character(len=:), allocatable :: filename
type(string_type) :: filecontents
type(state_type) :: err
! Get a temporary file name
filename = "test_get_file_size5.txt"
! Create a fixed-size file
open(newunit=ios, file=filename, action="write", form="unformatted", access="stream")
write(ios) "12345"
close(ios)
! Read and delete it
call get_file(filename, filecontents, err, delete=.true.)
call check(error, err%ok(), "Should not return error reading a non-empty file")
if (allocated(error)) return
call check(error, len_trim(filecontents) == 5, "Wrong string size returned")
if (allocated(error)) return
end subroutine test_get_file_non_empty
end module test_get_line
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_get_line, only : collect_get_line
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("get_line", collect_get_line) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/io/test_loadtxt.f90 0000664 0001750 0001750 00000033102 15135654166 022611 0 ustar alastair alastair module test_loadtxt
use stdlib_kinds, only: int32, sp, dp
use stdlib_io, only: loadtxt, savetxt
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_loadtxt
contains
!> Collect all exported unit tests
subroutine collect_loadtxt(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("loadtxt_int32", test_loadtxt_int32), &
new_unittest("loadtxt_sp", test_loadtxt_sp), &
new_unittest("loadtxt_sp_huge", test_loadtxt_sp_huge), &
new_unittest("loadtxt_sp_tiny", test_loadtxt_sp_tiny), &
new_unittest("loadtxt_dp", test_loadtxt_dp), &
new_unittest("loadtxt_dp_max_skip", test_loadtxt_dp_max_skip), &
new_unittest("loadtxt_dp_huge", test_loadtxt_dp_huge), &
new_unittest("loadtxt_dp_tiny", test_loadtxt_dp_tiny), &
new_unittest("loadtxt_complex", test_loadtxt_complex) &
]
end subroutine collect_loadtxt
subroutine test_loadtxt_int32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int32), allocatable :: input(:,:), expected(:,:)
real(sp), allocatable :: harvest(:,:)
integer :: n
allocate(harvest(10,10))
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(harvest)
input = int(harvest * 100)
call savetxt('test_int32.txt', input)
call loadtxt('test_int32.txt', expected)
call check(error, all(input == expected),'Default list directed read failed')
if (allocated(error)) return
call loadtxt('test_int32.txt', expected, fmt='*')
call check(error, all(input == expected),'User specified list directed read faile')
if (allocated(error)) return
call savetxt('test_int32.txt', input, delimiter=',')
call loadtxt('test_int32.txt', expected, delimiter=',')
call check(error, all(input == expected),'User specified delimiter `,` read failed')
if (allocated(error)) return
call savetxt('test_int32.txt', input, delimiter='-')
call loadtxt('test_int32.txt', expected, delimiter='-')
call check(error, all(input == expected),'User specified delimiter `-` read failed')
if (allocated(error)) return
end do
end subroutine test_loadtxt_int32
subroutine test_loadtxt_sp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(sp), allocatable :: input(:,:), expected(:,:)
character(len=*), parameter :: FMT_REAL_SP = '(es15.8e2)'
integer :: n
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(input)
input = input - 0.5
call savetxt('test_sp.txt', input)
call loadtxt('test_sp.txt', expected)
call check(error, all(input == expected),'Default format read failed')
if (allocated(error)) return
call loadtxt('test_sp.txt', expected, fmt='*')
call check(error, all(input == expected),'List directed read failed')
if (allocated(error)) return
call loadtxt('test_sp.txt', expected, fmt="(*"//FMT_REAL_sp(1:len(FMT_REAL_sp)-1)//",1x))")
call check(error, all(input == expected),'User specified format failed')
if (allocated(error)) return
call savetxt('test_sp.txt', input, delimiter=',')
call loadtxt('test_sp.txt', expected, delimiter=',')
call check(error, all(input == expected),'User specified delimiter `,` read failed')
if (allocated(error)) return
call savetxt('test_sp.txt', input, delimiter=';')
call loadtxt('test_sp.txt', expected, delimiter=';')
call check(error, all(input == expected),'User specified delimiter `;` read failed')
if (allocated(error)) return
end do
end subroutine test_loadtxt_sp
subroutine test_loadtxt_sp_huge(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(sp), allocatable :: input(:,:), expected(:,:)
integer :: n
character(len=*), parameter :: FMT_REAL_SP = '(es15.8e2)'
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(input)
input = (input - 0.5) * huge(input)
call savetxt('test_sp_huge.txt', input)
call loadtxt('test_sp_huge.txt', expected)
call check(error, all(input == expected),'Default format read failed')
if (allocated(error)) return
call loadtxt('test_sp_huge.txt', expected, fmt='*')
call check(error, all(input == expected),'List directed read failed')
if (allocated(error)) return
call loadtxt('test_sp_huge.txt', expected, fmt="(*"//FMT_REAL_sp(1:len(FMT_REAL_sp)-1)//",1x))")
call check(error, all(input == expected),'User specified format failed')
if (allocated(error)) return
end do
end subroutine test_loadtxt_sp_huge
subroutine test_loadtxt_sp_tiny(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(sp), allocatable :: input(:,:), expected(:,:)
integer :: n
character(len=*), parameter :: FMT_REAL_SP = '(es15.8e2)'
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(input)
input = (input - 0.5) * tiny(input)
call savetxt('test_sp_tiny.txt', input)
call loadtxt('test_sp_tiny.txt', expected)
call check(error, all(input == expected),'Default format read failed')
if (allocated(error)) return
call loadtxt('test_sp_tiny.txt', expected, fmt='*')
call check(error, all(input == expected),'List directed read failed')
if (allocated(error)) return
call loadtxt('test_sp_tiny.txt', expected, fmt="(*"//FMT_REAL_sp(1:len(FMT_REAL_sp)-1)//",1x))")
call check(error, all(input == expected),'User specified format failed')
if (allocated(error)) return
end do
end subroutine test_loadtxt_sp_tiny
subroutine test_loadtxt_dp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp), allocatable :: input(:,:), expected(:,:)
integer :: n
character(len=*), parameter :: FMT_REAL_DP = '(es24.16e3)'
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(input)
input = input - 0.5
call savetxt('test_dp.txt', input)
call loadtxt('test_dp.txt', expected)
call check(error, all(input == expected),'Default format read failed')
if (allocated(error)) return
call loadtxt('test_dp.txt', expected, fmt='*')
call check(error, all(input == expected),'List directed read failed')
if (allocated(error)) return
call loadtxt('test_dp.txt', expected, fmt="(*"//FMT_REAL_dp(1:len(FMT_REAL_dp)-1)//",1x))")
call check(error, all(input == expected),'User specified format failed')
if (allocated(error)) return
call savetxt('test_dp.txt', input, delimiter=',')
call loadtxt('test_dp.txt', expected, delimiter=',')
call check(error, all(input == expected),'User specified delimiter read failed')
if (allocated(error)) return
end do
end subroutine test_loadtxt_dp
subroutine test_loadtxt_dp_max_skip(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp), allocatable :: input(:,:), expected(:,:)
integer :: n, m
character(len=*), parameter :: FMT_REAL_DP = '(es24.16e3)'
allocate(input(10,10))
do m = 0, 5
do n = 1, 11
call random_number(input)
input = input - 0.5
call savetxt('test_dp_max_skip.txt', input)
call loadtxt('test_dp_max_skip.txt', expected, skiprows=m, max_rows=n)
call check(error, all(input(m+1:min(n+m,10),:) == expected),'Default format read failed')
if (allocated(error)) return
call loadtxt('test_dp_max_skip.txt', expected, skiprows=m, max_rows=n, fmt='*')
call check(error, all(input(m+1:min(n+m,10),:) == expected),'List directed read failed')
if (allocated(error)) return
call loadtxt('test_dp_max_skip.txt', expected, fmt="(*"//FMT_REAL_dp(1:len(FMT_REAL_dp)-1)//",1x))")
call check(error, all(input == expected),'User specified format failed')
deallocate(expected)
if (allocated(error)) return
end do
end do
end subroutine test_loadtxt_dp_max_skip
subroutine test_loadtxt_dp_huge(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp), allocatable :: input(:,:), expected(:,:)
integer :: n
character(len=*), parameter :: FMT_REAL_DP = '(es24.16e3)'
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(input)
input = (input - 0.5) * huge(input)
call savetxt('test_dp_huge.txt', input)
call loadtxt('test_dp_huge.txt', expected)
call check(error, all(input == expected),'Default format read failed')
if (allocated(error)) return
call loadtxt('test_dp_huge.txt', expected, fmt='*')
call check(error, all(input == expected),'List directed read failed')
if (allocated(error)) return
call loadtxt('test_dp_huge.txt', expected, fmt="(*"//FMT_REAL_dp(1:len(FMT_REAL_dp)-1)//",1x))")
call check(error, all(input == expected),'User specified format failed')
if (allocated(error)) return
end do
end subroutine test_loadtxt_dp_huge
subroutine test_loadtxt_dp_tiny(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp), allocatable :: input(:,:), expected(:,:)
integer :: n
character(len=*), parameter :: FMT_REAL_DP = '(es24.16e3)'
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(input)
input = (input - 0.5) * tiny(input)
call savetxt('test_dp_tiny.txt', input)
call loadtxt('test_dp_tiny.txt', expected)
call check(error, all(input == expected),'Default format read failed')
if (allocated(error)) return
call loadtxt('test_dp_tiny.txt', expected, fmt='*')
call check(error, all(input == expected),'List directed read failed')
if (allocated(error)) return
call loadtxt('test_dp_tiny.txt', expected, fmt="(*"//FMT_REAL_dp(1:len(FMT_REAL_dp)-1)//",1x))")
call check(error, all(input == expected),'User specified format failed')
if (allocated(error)) return
end do
end subroutine test_loadtxt_dp_tiny
subroutine test_loadtxt_complex(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(dp), allocatable :: input(:,:), expected(:,:)
real(dp), allocatable :: re(:,:), im(:,:)
integer :: n
character(len=*), parameter :: FMT_COMPLEX_DP = '(es24.16e3,1x,es24.16e3)'
allocate(re(10,10))
allocate(im(10,10))
allocate(input(10,10))
allocate(expected(10,10))
do n = 1, 10
call random_number(re)
call random_number(im)
input = cmplx(re, im)
call savetxt('test_complex.txt', input)
call loadtxt('test_complex.txt', expected)
call check(error, all(input == expected))
call loadtxt('test_complex.txt', expected, fmt="(*"//FMT_COMPLEX_dp(1:len(FMT_COMPLEX_dp)-1)//",1x))")
call check(error, all(input == expected))
if (allocated(error)) return
call savetxt('test_complex.txt', input, delimiter=',')
call loadtxt('test_complex.txt', expected, delimiter=',')
call check(error, all(input == expected))
if (allocated(error)) return
call savetxt('test_complex.txt', input, delimiter=';')
call loadtxt('test_complex.txt', expected, delimiter=';')
call check(error, all(input == expected))
if (allocated(error)) return
end do
end subroutine test_loadtxt_complex
end module test_loadtxt
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_loadtxt, only : collect_loadtxt
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("loadtxt", collect_loadtxt) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/selection/ 0000775 0001750 0001750 00000000000 15135654166 021132 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/selection/test_selection.fypp 0000664 0001750 0001750 00000051152 15135654166 025062 0 ustar alastair alastair #:include "common.fypp"
! Specify kinds/types for the input array in select and arg_select
#:set ARRAY_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES
! The index arrays are of all INT_KINDS_TYPES
module test_selection
use stdlib_kinds
use stdlib_selection, only: select, arg_select
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_selection
contains
!> Collect all exported unit tests
subroutine collect_selection(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("test_select_1_iint8_int8", test_select_1_iint8_int8) &
#:for arraykind, arraytype in ARRAY_KINDS_TYPES
#:for intkind, inttype in INT_KINDS_TYPES
#:set name = rname("test_select", 1, arraytype, arraykind, intkind)
, new_unittest("${name}$", ${name}$) &
#:endfor
#:endfor
#:for arraykind, arraytype in ARRAY_KINDS_TYPES
#:for intkind, inttype in INT_KINDS_TYPES
#:set name = rname("test_arg_select", 1, arraytype, arraykind, intkind)
, new_unittest("${name}$", ${name}$) &
#:endfor
#:endfor
]
end subroutine collect_selection
#:for arraykind, arraytype in ARRAY_KINDS_TYPES
#:for intkind, inttype in INT_KINDS_TYPES
#:set name = rname("test_select", 1, arraytype, arraykind, intkind)
subroutine ${name}$(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: ip = ${intkind}$
${inttype}$, parameter :: N = 10, Nm = 8
${inttype}$, parameter :: near_huge = HUGE(N) - 1_ip ! Segfaults without the -1_ip
${inttype}$, parameter :: Nreps = 2 ! Number of repetitions of random sampling
${inttype}$, parameter :: Nr = 25_ip ! Size of random array, must be < HUGE(N)
${arraytype}$ :: x(N), x_copy(N), mat(Nm), mat_copy(Nm), len1(1), len2(2), &
kth_smallest, random_vals(Nr), one = 1
${inttype}$ :: i, p, up_rank, down_rank, mid_rank
real(dp) :: random_doubles(Nr) ! Deliberately double precision for all cases
logical :: test1, test2, test3
${arraytype}$, allocatable :: long_array(:)
! x contains the numbers 1**2, 2**2, .... 10**2, with mixed-up order
x = (/( i**2, i=1, size(x, kind=ip) )/)
x(5:2:-1) = x(2:5)
x(10:8:-1) = x(8:10)
! Check that the ith-ranked entry of x really is i**2
do i = 1, size(x, kind=ip)
x_copy = x
call select(x_copy, i, kth_smallest)
call check( error, (kth_smallest == i**2), " ${name}$: kth smallest entry should be i**2")
if(allocated(error)) return
end do
! Check that it works when we specify "left" and know that the array
! is partially sorted due to previous calls to quickselect
x_copy = x
do i = 1, size(x, kind=ip), 1
call select(x_copy, i, kth_smallest, left=i)
call check( error, (kth_smallest == i**2), " ${name}$: kth smallest entry with left specified")
if(allocated(error)) return
end do
! Check that it works when we specify "right" and know that the array
! is partially sorted due to previous calls to quickselect
x_copy = x
do i = size(x, kind=ip), 1, -1
call select(x_copy, i, kth_smallest, right=i)
call check( error, (kth_smallest == i**2), " ${name}$: kth smallest entry with right specified")
if(allocated(error)) return
end do
! The test below can catch overflow in naive calculation of the middle index, like discussed here:
! https://ai.googleblog.com/2006/06/extra-extra-read-all-about-it-nearly.html
! But don't do it if near_huge is large, to avoid allocating a big array and slowing the tests
if(near_huge < 200) then
allocate(long_array(near_huge))
long_array = 0 * one
long_array(1:3) = one
call select(long_array, near_huge - 2_ip, kth_smallest)
call check( error, (kth_smallest == one), " ${name}$: designed to catch overflow in middle index")
if(allocated(error)) return
deallocate(long_array)
end if
! Simple tests
mat = one * [3, 2, 7, 4, 5, 1, 4, -1]
mat_copy = mat
call select(mat_copy, 1_ip, kth_smallest)
call check(error, kth_smallest == -1, " ${name}$: mat test 1")
if(allocated(error)) return
mat_copy = mat
call select(mat_copy, 2_ip, kth_smallest)
call check(error, kth_smallest == 1, " ${name}$: mat test 2")
if(allocated(error)) return
mat_copy = mat
call select(mat_copy, size(mat, kind=ip)+1_ip-4_ip, kth_smallest)
call check(error, kth_smallest == 4, " ${name}$: mat test 3")
if(allocated(error)) return
mat_copy = mat
call select(mat_copy, 5_ip, kth_smallest)
call check(error, kth_smallest == 4, " ${name}$: mat test 4")
if(allocated(error)) return
mat_copy = mat
call select(mat_copy, 6_ip, kth_smallest)
call check(error, kth_smallest == 4, " ${name}$: mat test 5")
if(allocated(error)) return
mat_copy = mat
call select(mat_copy, 7_ip, kth_smallest)
call check(error, kth_smallest == 5, " ${name}$: mat test 6")
if(allocated(error)) return
! Check it works for size(a) == 1
len1(1) = -1 * one
call select(len1, 1_ip, kth_smallest)
call check(error, kth_smallest == -1, " ${name}$: array with size 1")
if(allocated(error)) return
! Check it works for size(a) == 2
len2 = [-3, -5]*one
call select(len2, 2_ip, kth_smallest)
call check(error, kth_smallest == -3, " ${name}$: array with size 2, test 1")
if(allocated(error)) return
len2 = [-3, -5]*one
call select(len2, 1_ip, kth_smallest)
call check(error, kth_smallest == -5, " ${name}$: array with size 2, test 2")
if(allocated(error)) return
len2 = [-1, -1]*one
call select(len2, 1_ip, kth_smallest)
call check(error, kth_smallest == -1, " ${name}$: array with size 2, test 3")
if(allocated(error)) return
len2 = [-1, -1]*one
call select(len2, 2_ip, kth_smallest)
call check(error, kth_smallest == -1, " ${name}$: array with size 2, test 4")
if(allocated(error)) return
!
! Test using random data
!
! Search for the p-th smallest rank, for all these p
! (avoid end-points to enable constrained search tests)
do p = 3, Nr-2
! Repeat for different random samples to try to expose any errors
do i = 1, Nreps
! Make random numbers of the correct type
call random_number(random_doubles)
random_vals = random_doubles * Nr
call select(random_vals, p, kth_smallest)
test1 = kth_smallest == random_vals(p)
test2 = all(random_vals(1:(p-1)) <= random_vals(p))
test3 = all(random_vals(p) <= &
random_vals((p+1):size(random_vals, kind=ip)))
call check(error, (test1 .and. test2 .and. test3), "${name}$: random data regular select")
if(allocated(error)) return
! Constrained search above 'p', providing 'left'
up_rank = p + (Nr-p)/2_ip ! Deliberate integer division
call select(random_vals, up_rank, kth_smallest, left=p)
test1 = kth_smallest == random_vals(up_rank)
test2 = all(random_vals(1:(up_rank-1)) <= random_vals(up_rank))
test3 = all(random_vals(up_rank) <= &
random_vals((up_rank+1):size(random_vals, kind=ip)))
call check(error, (test1 .and. test2 .and. test3), "${name}$: random data left-constrained select")
if(allocated(error)) return
! Constrained search below p, providing 'right'
down_rank = p - (p/2_ip)
call select(random_vals, down_rank, kth_smallest, right=p)
test1 = kth_smallest == random_vals(down_rank)
test2 = all(random_vals(1:(down_rank-1)) <= &
random_vals(down_rank))
test3 = all(random_vals(down_rank) <= &
random_vals((down_rank+1):size(random_vals, kind=ip)))
call check(error, (test1 .and. test2 .and. test3), "${name}$: random data right-constrained select")
if(allocated(error)) return
! Constrained search between up-ind and down-ind, proving left
! and right. Make 'mid_rank' either above or below p
mid_rank = p - p/3_ip*mod(i,2_ip) + (Nr-p)/3_ip*(1_ip-mod(i,2_ip))
call select(random_vals, mid_rank, kth_smallest, &
left=down_rank, right=up_rank)
test1 = kth_smallest == random_vals(mid_rank)
test2 = all(random_vals(1:(mid_rank-1)) <= &
random_vals(mid_rank))
test3 = all(random_vals(mid_rank) <= &
random_vals((mid_rank+1):size(random_vals, kind=ip)))
call check(error, (test1 .and. test2 .and. test3), "${name}$: random data left-right-constrained select")
if(allocated(error)) return
end do
end do
end subroutine
#:endfor
#:endfor
#:for arraykind, arraytype in ARRAY_KINDS_TYPES
#:for intkind, inttype in INT_KINDS_TYPES
#:set name = rname("test_arg_select", 1, arraytype, arraykind, intkind)
subroutine ${name}$(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: ip = ${intkind}$
${inttype}$, parameter :: N = 10, Nm = 8
${inttype}$, parameter :: near_huge = HUGE(N) - 1_ip ! Segfaults without the -1_ip
${inttype}$, parameter :: Nreps = 2 ! Number of repetitions of random sampling
${inttype}$, parameter :: Nr = 25_ip ! Size of random array, must be < HUGE(N)
${arraytype}$ :: x(N), mat(Nm), len1(1), len2(2), random_vals(Nr), one=1
integer(ip) :: indx(N), indx_copy(N), indx_mat(Nm), indx_mat_copy(Nm), &
indx_len1(1), indx_len2(2), indx_r(Nr)
real(dp) :: random_doubles(Nr) ! Deliberately double precision for all cases
integer(ip) :: i, j, p, up_rank, down_rank, mid_rank, kth_smallest
logical :: test1, test2, test3
${arraytype}$, allocatable :: long_array(:)
${inttype}$, allocatable :: long_array_index(:)
! Make x contain 1**2, 2**2, .... 10**2, but mix up the order
x = (/( i**2, i=1, size(x, kind=ip) )/)
x(5:2:-1) = x(2:5)
x(10:8:-1) = x(8:10)
indx = (/(i, i = 1, size(x, kind=ip))/)
! Check that the ith ranked entry of x equals i**2
do i = 1, size(x, kind=ip)
indx_copy = indx
call arg_select(x, indx, i, kth_smallest)
call check(error, x(kth_smallest) == i**2, " ${name}$: kth smallest entry should be i**2")
if(allocated(error)) return
end do
! Check that it works when we specify "left" and know that the index
! array is partially sorted due to previous calls to arg_select
indx_copy = indx
do i = 1, size(x, kind=ip), 1
call arg_select(x, indx_copy, i, kth_smallest, left=i)
call check(error, (x(kth_smallest) == i**2), " ${name}$: kth smallest entry with left specified")
if(allocated(error)) return
end do
! Check that it works when we specify "right" and know that the index
! array is partially sorted due to previous calls to arg_select
indx_copy = indx
do i = size(x, kind=ip), 1, -1
call arg_select(x, indx_copy, i, kth_smallest, right=i)
call check(error, (x(kth_smallest) == i**2), " ${name}$: kth smallest entry with right specified")
if(allocated(error)) return
end do
! The test below would catch overflow in naive calculation of the middle index, like discussed here:
! https://ai.googleblog.com/2006/06/extra-extra-read-all-about-it-nearly.html
! But don't do it if near_huge is large, to avoid allocating a big array and slowing the tests
if(near_huge < 200) then
allocate(long_array(near_huge))
allocate(long_array_index(near_huge))
long_array = 0 * one
long_array(1:3) = one
long_array_index = (/( i, i = 1_ip, size(long_array, kind=ip) )/)
call arg_select(long_array, long_array_index, near_huge - 2_ip, kth_smallest)
call check( error, (kth_smallest < 4), " ${name}$: designed to catch overflow in middle index")
if(allocated(error)) return
deallocate(long_array, long_array_index)
end if
! Simple tests
mat = one * [3, 2, 7, 4, 5, 1, 4, -1]
indx_mat = (/( i, i = 1, size(mat, kind=ip) )/)
indx_mat_copy = indx_mat
call arg_select(mat, indx_mat_copy, 1_ip, kth_smallest)
call check(error, mat(kth_smallest) == -1, " ${name}$: mat test 1")
if(allocated(error)) return
indx_mat_copy = indx_mat
call arg_select(mat, indx_mat_copy, 2_ip, kth_smallest)
call check(error, mat(kth_smallest) == 1, " ${name}$: mat test 2")
if(allocated(error)) return
indx_mat_copy = indx_mat
call arg_select(mat, indx_mat_copy, size(mat, kind=ip)+1_ip-4_ip, &
kth_smallest)
call check(error, mat(kth_smallest) == 4, " ${name}$: mat test 3")
if(allocated(error)) return
indx_mat_copy = indx_mat
call arg_select(mat, indx_mat_copy, 5_ip, kth_smallest)
call check(error, mat(kth_smallest) == 4, " ${name}$: mat test 4")
if(allocated(error)) return
indx_mat_copy = indx_mat
call arg_select(mat, indx_mat_copy, 6_ip, kth_smallest)
call check(error, mat(kth_smallest) == 4, " ${name}$: mat test 5")
if(allocated(error)) return
indx_mat_copy = indx_mat
call arg_select(mat, indx_mat_copy, 7_ip, kth_smallest)
call check(error, mat(kth_smallest) == 5, " ${name}$: mat test 6")
if(allocated(error)) return
! Check it works for size(a) == 1
len1(1) = -1 * one
indx_len1(1) = 1
call arg_select(len1, indx_len1, 1_ip, kth_smallest)
call check(error, len1(kth_smallest) == -1, " ${name}$: array with size 1")
if(allocated(error)) return
! Check it works for size(a) == 2
len2 = [-3, -5] * one
indx_len2 = [1_ip, 2_ip]
call arg_select(len2, indx_len2, 2_ip, kth_smallest)
call check(error, len2(kth_smallest) == -3, " ${name}$: array with size 2, test 1")
if(allocated(error)) return
len2 = [-3, -5] * one
indx_len2 = [1_ip, 2_ip]
call arg_select(len2, indx_len2, 1_ip, kth_smallest)
call check(error, len2(kth_smallest) == -5, " ${name}$: array with size 2, test 2")
if(allocated(error)) return
len2 = [-1, -1] * one
indx_len2 = [1_ip, 2_ip]
call arg_select(len2, indx_len2, 1_ip, kth_smallest)
call check(error, len2(kth_smallest) == -1, " ${name}$: array with size 2, test 3")
if(allocated(error)) return
len2 = [-1, -1] * one
indx_len2 = [1_ip, 2_ip]
call arg_select(len2, indx_len2, 2_ip, kth_smallest)
call check(error, len2(kth_smallest) == -1, " ${name}$: array with size 2, test 4")
if(allocated(error)) return
!
! Test using random data
!
! Search for the p-th smallest, for all these p (avoid end-points to
! enable additional tests using "left", "right" arguments)
do p = 3, Nr-2
! Repeat for many random samples to try to expose any errors
do i = 1, Nreps
! Make random numbers of the correct type
call random_number(random_doubles)
random_vals = random_doubles * Nr
indx_r = (/( j, j = 1, size(random_vals, kind=ip) )/)
! Standard arg_select
call arg_select(random_vals, indx_r, p, kth_smallest)
test1 = random_vals(kth_smallest) == random_vals(indx_r(p))
test2 = all(random_vals(indx_r(1:(p-1))) <= &
random_vals(indx_r(p)))
test3 = all(random_vals(indx_r(p)) <= &
random_vals(indx_r((p+1):size(random_vals, kind=ip))))
call check(error, (test1 .and. test2 .and. test3), "${name}$: random data regular arg_select")
if(allocated(error)) return
! Constrained search for a rank above 'p', providing 'left'
up_rank = p + (Nr-p)/2_ip ! Deliberate integer division
call arg_select(random_vals, indx_r, up_rank, &
kth_smallest, left=p)
test1 = random_vals(kth_smallest) == &
random_vals(indx_r(up_rank))
test2 = all(random_vals(indx_r(1:(up_rank-1))) <= &
random_vals(indx_r(up_rank)))
test3 = all(random_vals(indx_r(up_rank)) <= &
random_vals(indx_r((up_rank+1):size(random_vals, kind=ip))))
call check(error, (test1 .and. test2 .and. test3), "${name}$: random data left-constrained arg_select")
if(allocated(error)) return
! Constrained search for a rank below p, providing 'right'
down_rank = p - (p/2_ip)
call arg_select(random_vals, indx_r, down_rank, &
kth_smallest, right=p)
test1 = random_vals(kth_smallest) == &
random_vals(indx_r(down_rank))
test2 = all(random_vals(indx_r(1:(down_rank-1))) <= &
random_vals(indx_r(down_rank)))
test3 = all(random_vals(indx_r(down_rank)) <= &
random_vals(indx_r((down_rank+1):size(random_vals, kind=ip))))
call check(error, (test1 .and. test2 .and. test3), "${name}$: random data right-constrained arg_select")
if(allocated(error)) return
! Constrained search for a rank between up-ind and down-ind,
! proving left and right. 'mid_rank' is either above or below p
mid_rank = p - p/3_ip*mod(i,2_ip) + (Nr-p)/3_ip*(1_ip-mod(i,2_ip))
call arg_select(random_vals, indx_r, mid_rank, &
kth_smallest, left=down_rank, right=up_rank)
test1 = random_vals(kth_smallest) == &
random_vals(indx_r(mid_rank))
test2 = all(random_vals(indx_r(1:(mid_rank-1))) <= &
random_vals(indx_r(mid_rank)))
test3 = all(random_vals(indx_r(mid_rank)) <= &
random_vals(indx_r((mid_rank+1):size(random_vals, kind=ip))))
call check(error, (test1 .and. test2 .and. test3), "${name}$: random data left-right-constrained arg_select")
if(allocated(error)) return
end do
end do
end subroutine
#:endfor
#:endfor
end module
program tester
use, intrinsic :: iso_fortran_env, only: compiler_version, error_unit
use testdrive, only: new_testsuite, run_testsuite, testsuite_type
use test_selection, only: collect_selection
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("selection", collect_selection) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/selection/CMakeLists.txt 0000664 0001750 0001750 00000000307 15135654166 023672 0 ustar alastair alastair ### Pre-process: .fpp -> .f90 via Fypp
# Create a list of the files to be preprocessed
set(
fppFiles
test_selection.fypp
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(selection)
fortran-lang-stdlib-0ede301/test/hash_functions/ 0000775 0001750 0001750 00000000000 15135654166 022160 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/hash_functions/test_hash_functions.f90 0000664 0001750 0001750 00000021664 15135654166 026563 0 ustar alastair alastair module test_hash_functions
use testdrive, only : new_unittest, unittest_type, error_type, check, &
skip_test
use stdlib_kinds, only: int8, int32, int64, dp
use stdlib_hash_32bit, only: little_endian &
, nmhash32 &
, nmhash32x &
, water_hash
use stdlib_hash_64bit, only: pengy_hash, spooky_hash
implicit none
private
public :: collect_hash_functions
public :: generate_key_array
integer, parameter :: size_key_array = 2048
integer(int32), parameter :: nm_seed = int( z'deadbeef', int32 )
integer(int64), parameter :: water_seed = int( z'deadbeef1eadbeef', int64 )
integer(int32), parameter :: pengy_seed = int( z'deadbeef', int32 )
integer(int64), parameter :: spooky_seed(2) = [ water_seed, water_seed ]
interface read_array
module procedure read_array_int8
module procedure read_array_int32
module procedure read_array_int64
module procedure read_2darray_int64
end interface
contains
!> Collect all exported unit tests
subroutine collect_hash_functions(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("little_endian", test_little_endian) &
, new_unittest("nmhash32", test_nmhash32) &
, new_unittest("nmhash32x", test_nmhash32x) &
, new_unittest("water_hash", test_water_hash) &
, new_unittest("pengy_hash", test_pengy_hash) &
, new_unittest("spooky_hash", test_spooky_hash) &
]
end subroutine collect_hash_functions
subroutine test_little_endian(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! Test for endianness
call check(error, little_endian, "The processor is not Little-Endian")
if (allocated(error)) return
end subroutine test_little_endian
subroutine test_nmhash32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: index
integer(int8) :: key_array(size_key_array)
integer(int32) :: c_hash(0:size_key_array)
call read_array("key_array.bin", key_array )
! Read hash array generated from key array by the C version of nmhash32
call read_array("c_nmhash32_array.bin", c_hash)
do index=0, size_key_array
call check(error, c_hash(index) == nmhash32(key_array(1:index), nm_seed) &
, "NMHASH32 failed")
if (allocated(error)) return
end do
end subroutine test_nmhash32
subroutine test_nmhash32x(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: index
integer(int8) :: key_array(size_key_array)
integer(int32) :: c_hash(0:size_key_array)
call read_array("key_array.bin", key_array )
! Read hash array generated from key array by the C version of nmhash32x
call read_array("c_nmhash32x_array.bin", c_hash)
do index=0, size_key_array
call check(error, c_hash(index) == nmhash32x(key_array(1:index), nm_seed) &
, "NMHASH32X failed")
if (allocated(error)) return
end do
end subroutine test_nmhash32x
subroutine test_water_hash(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: index
integer(int8) :: key_array(size_key_array)
integer(int32) :: c_hash(0:size_key_array)
call read_array("key_array.bin", key_array )
! Read hash array generated from key array by the C version of water_hash
call read_array("c_water_hash_array.bin", c_hash)
do index=0, size_key_array
call check(error, c_hash(index) == water_hash(key_array(1:index), water_seed) &
, "WATER_HASH failed")
if (allocated(error)) return
end do
end subroutine test_water_hash
subroutine test_pengy_hash(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: index
integer(int8) :: key_array(size_key_array)
integer(int64) :: c_hash(0:size_key_array)
call read_array("key_array.bin", key_array )
! Read hash array generated from key array by the C version of pengy_hash
call read_array("c_pengy_hash_array.bin", c_hash)
do index=0, size_key_array
call check(error, c_hash(index) == pengy_hash(key_array(1:index), pengy_seed) &
, "PENGY_HASH failed")
if (allocated(error)) return
end do
end subroutine test_pengy_hash
subroutine test_spooky_hash(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: index
integer(int8) :: key_array(size_key_array)
integer(int64) :: c_hash(0:1, 0:size_key_array)
call read_array("key_array.bin", key_array )
! Read hash array generated from key array by the C version of spooky_hash
call read_array("c_spooky_hash_array.bin", c_hash)
do index=0, size_key_array
call check(error, all(c_hash(:, index) == spooky_hash(key_array(1:index), spooky_seed)) &
, "SPOOKY_HASH failed")
if (allocated(error)) return
end do
end subroutine test_spooky_hash
subroutine generate_key_array()
integer :: i, lun
integer(int8) :: key_array(size_key_array)
integer(int32) :: dummy(size_key_array/4)
real(dp) :: rand(size_key_array/4)
! Create key array
call random_number( rand )
do i=1, size_key_array/4
dummy(i) = floor( rand(i) * 2_int64**32 - 2_int64**31, kind=int32 )
end do
key_array = transfer( dummy, 0_int8, size_key_array )
open(newunit=lun, file="key_array.bin", form="unformatted", &
access="stream", status="replace", action="write")
write(lun) key_array
close(lun)
end subroutine generate_key_array
subroutine read_array_int8(filename, res)
character(*), intent(in) :: filename
integer(int8), intent(out) :: res(:)
integer :: lun
open(newunit=lun, file=filename, form="unformatted", &
access="stream", status="old", action="read", err = 9908)
read(lun) res
close(lun)
return
9908 res = 0
end subroutine read_array_int8
subroutine read_array_int32(filename, res)
character(*), intent(in) :: filename
integer(int32), intent(out) :: res(:)
integer :: lun
open(newunit=lun, file=filename, form="unformatted", &
access="stream", status="old", action="read", err = 9908)
read(lun) res
close(lun)
return
9908 res = 0
end subroutine read_array_int32
subroutine read_array_int64(filename, res)
character(*), intent(in) :: filename
integer(int64), intent(out) :: res(:)
integer :: lun
open(newunit=lun, file=filename, form="unformatted", &
access="stream", status="old", action="read", err = 9908)
read(lun) res
close(lun)
return
9908 res = 0
end subroutine read_array_int64
subroutine read_2darray_int64(filename, res)
character(*), intent(in) :: filename
integer(int64), intent(out) :: res(:,:)
integer :: lun
open(newunit=lun, file=filename, form="unformatted", &
access="stream", status="old", action="read", err = 9908)
read(lun) res
close(lun)
return
9908 res = 0
end subroutine read_2darray_int64
end module
module modchash
use, intrinsic :: ISO_C_Binding
implicit none
private
public :: generate_all_c_hash
interface
function generate_all_c_hash() result(error) bind(C,name = "generate_all_c_hash")
import C_int
integer(C_int) :: error
end function
end interface
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use, intrinsic :: ISO_C_Binding, only : C_int
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_hash_functions, only : collect_hash_functions, generate_key_array
use modchash, only: generate_all_c_hash
implicit none
integer(C_int) :: error
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
call generate_key_array()
error = generate_all_c_hash()
stat = 0
testsuites = [ &
new_testsuite("hash_functions", collect_hash_functions) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/hash_functions/pengyhash.c 0000664 0001750 0001750 00000001510 15135654166 024307 0 ustar alastair alastair /* pengyhash v0.2 */
#include "pengyhash.h"
uint64_t pengyhash(const void *p, size_t size, uint32_t seed)
{
uint64_t b[4] = { 0 };
uint64_t s[4] = { 0, 0, 0, size };
int i;
for(; size >= 32; size -= 32, p = (const char*)p + 32) {
memcpy(b, p, 32);
s[1] = (s[0] += s[1] + b[3]) + (s[1] << 14 | s[1] >> 50);
s[3] = (s[2] += s[3] + b[2]) + (s[3] << 23 | s[3] >> 41);
s[3] = (s[0] += s[3] + b[1]) ^ (s[3] << 16 | s[3] >> 48);
s[1] = (s[2] += s[1] + b[0]) ^ (s[1] << 40 | s[1] >> 24);
}
memcpy(b, p, size);
for(i = 0; i < 6; i++) {
s[1] = (s[0] += s[1] + b[3]) + (s[1] << 14 | s[1] >> 50) + seed;
s[3] = (s[2] += s[3] + b[2]) + (s[3] << 23 | s[3] >> 41);
s[3] = (s[0] += s[3] + b[1]) ^ (s[3] << 16 | s[3] >> 48);
s[1] = (s[2] += s[1] + b[0]) ^ (s[1] << 40 | s[1] >> 24);
}
return s[0] + s[1] + s[2] + s[3];
}
fortran-lang-stdlib-0ede301/test/hash_functions/nmhash.c 0000664 0001750 0001750 00000000421 15135654166 023577 0 ustar alastair alastair #include "nmhash.h"
int32_t nmhash32_test ( const void * key, size_t len, uint32_t seed ) {
return NMHASH32 (key, (const size_t) len, seed);
}
int32_t nmhash32x_test ( const void * key, size_t len, uint32_t seed ) {
return NMHASH32X (key, (const size_t) len, seed);
}
fortran-lang-stdlib-0ede301/test/hash_functions/README.md 0000664 0001750 0001750 00000001255 15135654166 023442 0 ustar alastair alastair The hash_functions directory contains code to validate the Fortran hash functions against the original C/C++ codes. It consists of one executable `test_hash_functions` that:
* creates a file containing 2048 random 8 bit integers using the subroutine
`generate_key_array`.
* reads the file generated by the subroutine `generate_key_array` and uses its contents to generate 2049 hashes for each C/C++ hash algorithm and outputs files containing the hashes.
* reads the file generated by the subroutine `generate_key_array` and uses its contents to generate 2049 hashes for each Fortran hash algorithm and compares the result with the corresponding outputs of C/C++ hash algorithms.
fortran-lang-stdlib-0ede301/test/hash_functions/CMakeLists.txt 0000775 0001750 0001750 00000002346 15135654166 024730 0 ustar alastair alastair #ADDTEST(hash_functions)
enable_language(CXX)
enable_language(C)
ADDTEST(hash_functions)
target_sources(
test_hash_functions
PRIVATE
nmhash.c
pengyhash.c
SpookyV2.cpp
SpookyV2Test.cpp
waterhash.c
generate_hash_arrays.cpp
)
if(CMAKE_Fortran_COMPILER_ID MATCHES "^Intel")
# Set the C++ standard to prevent icpc breakage
set(CMAKE_CXX_STANDARD 11)
set(CMAKE_CXX_STANDARD_REQUIRED ON)
set(CMAKE_CXX_EXTENSIONS OFF)
set_target_properties(test_hash_functions PROPERTIES LINKER_LANGUAGE Fortran)
if(WIN32)
set(CMAKE_MSVC_RUNTIME_LIBRARY "MultiThreadedDLL$<$:Debug>")
target_compile_options(
test_hash_functions
PRIVATE
$<$:/libs:dll> )
if (CMAKE_BUILD_TYPE STREQUAL "Debug" OR "RelWithDebInfo")
target_link_options(test_hash_functions
PRIVATE
/Qoption,link,/NODEFAULTLIB:libcmt
/Qoption,link,/NODEFAULTLIB:msvcrt.lib
/Qoption,link,/NODEFAULTLIB:libifcoremt.lib )
endif()
endif()
endif()
if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU AND CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 10.0)
target_compile_options(
test_hash_functions
PRIVATE
$<$:-fno-range-check>
)
endif()
fortran-lang-stdlib-0ede301/test/hash_functions/SpookyV2.h 0000664 0001750 0001750 00000027165 15135654166 024040 0 ustar alastair alastair //
// SpookyHash: a 128-bit noncryptographic hash function
// By Bob Jenkins, public domain
// Oct 31 2010: alpha, framework + SpookyHash::Mix appears right
// Oct 31 2011: alpha again, Mix only good to 2^^69 but rest appears right
// Dec 31 2011: beta, improved Mix, tested it for 2-bit deltas
// Feb 2 2012: production, same bits as beta
// Feb 5 2012: adjusted definitions of uint* to be more portable
// Mar 30 2012: 3 bytes/cycle, not 4. Alpha was 4 but wasn't thorough enough.
// August 5 2012: SpookyV2 (different results)
//
// Up to 3 bytes/cycle for long messages. Reasonably fast for short messages.
// All 1 or 2 bit deltas achieve avalanche within 1% bias per output bit.
//
// This was developed for and tested on 64-bit x86-compatible processors.
// It assumes the processor is little-endian. There is a macro
// controlling whether unaligned reads are allowed (by default they are).
// This should be an equally good hash on big-endian machines, but it will
// compute different results on them than on little-endian machines.
//
// Google's CityHash has similar specs to SpookyHash, and CityHash is faster
// on new Intel boxes. MD4 and MD5 also have similar specs, but they are orders
// of magnitude slower. CRCs are two or more times slower, but unlike
// SpookyHash, they have nice math for combining the CRCs of pieces to form
// the CRCs of wholes. There are also cryptographic hashes, but those are even
// slower than MD5.
//
#include
#ifdef _MSC_VER
# define INLINE __forceinline
typedef unsigned __int64 uint64;
typedef unsigned __int32 uint32;
typedef unsigned __int16 uint16;
typedef unsigned __int8 uint8;
#else
# include
# define INLINE inline
typedef uint64_t uint64;
typedef uint32_t uint32;
typedef uint16_t uint16;
typedef uint8_t uint8;
#endif
class SpookyHash
{
public:
//
// SpookyHash: hash a single message in one call, produce 128-bit output
//
static void Hash128(
const void *message, // message to hash
size_t length, // length of message in bytes
uint64 *hash1, // in/out: in seed 1, out hash value 1
uint64 *hash2); // in/out: in seed 2, out hash value 2
//
// Hash64: hash a single message in one call, return 64-bit output
//
static uint64 Hash64(
const void *message, // message to hash
size_t length, // length of message in bytes
uint64 seed) // seed
{
uint64 hash1 = seed;
Hash128(message, length, &hash1, &seed);
return hash1;
}
//
// Hash32: hash a single message in one call, produce 32-bit output
//
static uint32 Hash32(
const void *message, // message to hash
size_t length, // length of message in bytes
uint32 seed) // seed
{
uint64 hash1 = seed, hash2 = seed;
Hash128(message, length, &hash1, &hash2);
return (uint32)hash1;
}
//
// Init: initialize the context of a SpookyHash
//
void Init(
uint64 seed1, // any 64-bit value will do, including 0
uint64 seed2); // different seeds produce independent hashes
//
// Update: add a piece of a message to a SpookyHash state
//
void Update(
const void *message, // message fragment
size_t length); // length of message fragment in bytes
//
// Final: compute the hash for the current SpookyHash state
//
// This does not modify the state; you can keep updating it afterward
//
// The result is the same as if SpookyHash() had been called with
// all the pieces concatenated into one message.
//
void Final(
uint64 *hash1, // out only: first 64 bits of hash value.
uint64 *hash2); // out only: second 64 bits of hash value.
//
// left rotate a 64-bit value by k bytes
//
static INLINE uint64 Rot64(uint64 x, int k)
{
return (x << k) | (x >> (64 - k));
}
//
// This is used if the input is 96 bytes long or longer.
//
// The internal state is fully overwritten every 96 bytes.
// Every input bit appears to cause at least 128 bits of entropy
// before 96 other bytes are combined, when run forward or backward
// For every input bit,
// Two inputs differing in just that input bit
// Where "differ" means xor or subtraction
// And the base value is random
// When run forward or backwards one Mix
// I tried 3 pairs of each; they all differed by at least 212 bits.
//
static INLINE void Mix(
const uint64 *data,
uint64 &s0, uint64 &s1, uint64 &s2, uint64 &s3,
uint64 &s4, uint64 &s5, uint64 &s6, uint64 &s7,
uint64 &s8, uint64 &s9, uint64 &s10,uint64 &s11)
{
s0 += data[0]; s2 ^= s10; s11 ^= s0; s0 = Rot64(s0,11); s11 += s1;
s1 += data[1]; s3 ^= s11; s0 ^= s1; s1 = Rot64(s1,32); s0 += s2;
s2 += data[2]; s4 ^= s0; s1 ^= s2; s2 = Rot64(s2,43); s1 += s3;
s3 += data[3]; s5 ^= s1; s2 ^= s3; s3 = Rot64(s3,31); s2 += s4;
s4 += data[4]; s6 ^= s2; s3 ^= s4; s4 = Rot64(s4,17); s3 += s5;
s5 += data[5]; s7 ^= s3; s4 ^= s5; s5 = Rot64(s5,28); s4 += s6;
s6 += data[6]; s8 ^= s4; s5 ^= s6; s6 = Rot64(s6,39); s5 += s7;
s7 += data[7]; s9 ^= s5; s6 ^= s7; s7 = Rot64(s7,57); s6 += s8;
s8 += data[8]; s10 ^= s6; s7 ^= s8; s8 = Rot64(s8,55); s7 += s9;
s9 += data[9]; s11 ^= s7; s8 ^= s9; s9 = Rot64(s9,54); s8 += s10;
s10 += data[10]; s0 ^= s8; s9 ^= s10; s10 = Rot64(s10,22); s9 += s11;
s11 += data[11]; s1 ^= s9; s10 ^= s11; s11 = Rot64(s11,46); s10 += s0;
}
//
// Mix all 12 inputs together so that h0, h1 are a hash of them all.
//
// For two inputs differing in just the input bits
// Where "differ" means xor or subtraction
// And the base value is random, or a counting value starting at that bit
// The final result will have each bit of h0, h1 flip
// For every input bit,
// with probability 50 +- .3%
// For every pair of input bits,
// with probability 50 +- 3%
//
// This does not rely on the last Mix() call having already mixed some.
// Two iterations was almost good enough for a 64-bit result, but a
// 128-bit result is reported, so End() does three iterations.
//
static INLINE void EndPartial(
uint64 &h0, uint64 &h1, uint64 &h2, uint64 &h3,
uint64 &h4, uint64 &h5, uint64 &h6, uint64 &h7,
uint64 &h8, uint64 &h9, uint64 &h10,uint64 &h11)
{
h11+= h1; h2 ^= h11; h1 = Rot64(h1,44);
h0 += h2; h3 ^= h0; h2 = Rot64(h2,15);
h1 += h3; h4 ^= h1; h3 = Rot64(h3,34);
h2 += h4; h5 ^= h2; h4 = Rot64(h4,21);
h3 += h5; h6 ^= h3; h5 = Rot64(h5,38);
h4 += h6; h7 ^= h4; h6 = Rot64(h6,33);
h5 += h7; h8 ^= h5; h7 = Rot64(h7,10);
h6 += h8; h9 ^= h6; h8 = Rot64(h8,13);
h7 += h9; h10^= h7; h9 = Rot64(h9,38);
h8 += h10; h11^= h8; h10= Rot64(h10,53);
h9 += h11; h0 ^= h9; h11= Rot64(h11,42);
h10+= h0; h1 ^= h10; h0 = Rot64(h0,54);
}
static INLINE void End(
const uint64 *data,
uint64 &h0, uint64 &h1, uint64 &h2, uint64 &h3,
uint64 &h4, uint64 &h5, uint64 &h6, uint64 &h7,
uint64 &h8, uint64 &h9, uint64 &h10,uint64 &h11)
{
h0 += data[0]; h1 += data[1]; h2 += data[2]; h3 += data[3];
h4 += data[4]; h5 += data[5]; h6 += data[6]; h7 += data[7];
h8 += data[8]; h9 += data[9]; h10 += data[10]; h11 += data[11];
EndPartial(h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
EndPartial(h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
EndPartial(h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
}
//
// The goal is for each bit of the input to expand into 128 bits of
// apparent entropy before it is fully overwritten.
// n trials both set and cleared at least m bits of h0 h1 h2 h3
// n: 2 m: 29
// n: 3 m: 46
// n: 4 m: 57
// n: 5 m: 107
// n: 6 m: 146
// n: 7 m: 152
// when run forwards or backwards
// for all 1-bit and 2-bit diffs
// with diffs defined by either xor or subtraction
// with a base of all zeros plus a counter, or plus another bit, or random
//
static INLINE void ShortMix(uint64 &h0, uint64 &h1, uint64 &h2, uint64 &h3)
{
h2 = Rot64(h2,50); h2 += h3; h0 ^= h2;
h3 = Rot64(h3,52); h3 += h0; h1 ^= h3;
h0 = Rot64(h0,30); h0 += h1; h2 ^= h0;
h1 = Rot64(h1,41); h1 += h2; h3 ^= h1;
h2 = Rot64(h2,54); h2 += h3; h0 ^= h2;
h3 = Rot64(h3,48); h3 += h0; h1 ^= h3;
h0 = Rot64(h0,38); h0 += h1; h2 ^= h0;
h1 = Rot64(h1,37); h1 += h2; h3 ^= h1;
h2 = Rot64(h2,62); h2 += h3; h0 ^= h2;
h3 = Rot64(h3,34); h3 += h0; h1 ^= h3;
h0 = Rot64(h0,5); h0 += h1; h2 ^= h0;
h1 = Rot64(h1,36); h1 += h2; h3 ^= h1;
}
//
// Mix all 4 inputs together so that h0, h1 are a hash of them all.
//
// For two inputs differing in just the input bits
// Where "differ" means xor or subtraction
// And the base value is random, or a counting value starting at that bit
// The final result will have each bit of h0, h1 flip
// For every input bit,
// with probability 50 +- .3% (it is probably better than that)
// For every pair of input bits,
// with probability 50 +- .75% (the worst case is approximately that)
//
static INLINE void ShortEnd(uint64 &h0, uint64 &h1, uint64 &h2, uint64 &h3)
{
h3 ^= h2; h2 = Rot64(h2,15); h3 += h2;
h0 ^= h3; h3 = Rot64(h3,52); h0 += h3;
h1 ^= h0; h0 = Rot64(h0,26); h1 += h0;
h2 ^= h1; h1 = Rot64(h1,51); h2 += h1;
h3 ^= h2; h2 = Rot64(h2,28); h3 += h2;
h0 ^= h3; h3 = Rot64(h3,9); h0 += h3;
h1 ^= h0; h0 = Rot64(h0,47); h1 += h0;
h2 ^= h1; h1 = Rot64(h1,54); h2 += h1;
h3 ^= h2; h2 = Rot64(h2,32); h3 += h2;
h0 ^= h3; h3 = Rot64(h3,25); h0 += h3;
h1 ^= h0; h0 = Rot64(h0,63); h1 += h0;
}
private:
//
// Short is used for messages under 192 bytes in length
// Short has a low startup cost, the normal mode is good for long
// keys, the cost crossover is at about 192 bytes. The two modes were
// held to the same quality bar.
//
static void Short(
const void *message, // message (array of bytes, not necessarily aligned)
size_t length, // length of message (in bytes)
uint64 *hash1, // in/out: in the seed, out the hash value
uint64 *hash2); // in/out: in the seed, out the hash value
// number of uint64's in internal state
static const size_t sc_numVars = 12;
// size of the internal state
static const size_t sc_blockSize = sc_numVars*8;
// size of buffer of unhashed data, in bytes
static const size_t sc_bufSize = 2*sc_blockSize;
//
// sc_const: a constant which:
// * is not zero
// * is odd
// * is a not-very-regular mix of 1's and 0's
// * does not need any other special mathematical properties
//
static const uint64 sc_const = 0xdeadbeefdeadbeefLL;
uint64 m_data[2*sc_numVars]; // unhashed data, for partial messages
uint64 m_state[sc_numVars]; // internal state of the hash
size_t m_length; // total length of the input so far
uint8 m_remainder; // length of unhashed data stashed in m_data
};
fortran-lang-stdlib-0ede301/test/hash_functions/SpookyV2Test.cpp 0000664 0001750 0001750 00000002507 15135654166 025224 0 ustar alastair alastair #include "SpookyV2.h"
#ifdef __cplusplus
extern "C" {
#endif
void SpookyHash32_with_state_test(const void *key, size_t len, const void *state, void *out) {
uint64 *state64= (uint64 *)state;
uint64 s0 = state64[0];
uint64 s1 = state64[1];
SpookyHash::Hash128(key, len, &s0, &s1);
((uint32 *)out)[0]= (uint32)s0;
}
void SpookyHash64_with_state_test(const void *key, size_t len, const void *state, void *out) {
uint64 *state64= (uint64 *)state;
uint64 *out64= (uint64 *)out;
out64[0] = state64[0];
uint64 s1 = state64[1];
SpookyHash::Hash128(key, len, out64, &s1);
}
void SpookyHash128_with_state_test(const void *key, size_t len, const void *state, void *out) {
uint64 *state64= (uint64 *)state;
uint64 *out64= (uint64 *)out;
out64[0] = state64[0];
out64[1] = state64[1];
SpookyHash::Hash128(key, len, out64, out64+1);
}
void SpookyHash_seed_state_test(int in_bits, const void *seed, void *state) {
uint64 *state64= (uint64 *)state;
if (in_bits == 32) {
state64[0]= state64[1]= ((uint32*)seed)[0];
}
else {
uint64 *seed64= (uint64 *)seed;
if (in_bits == 64) {
state64[0]= state64[1]= seed64[0];
}
else
if (in_bits == 128) {
state64[0]= seed64[0];
state64[1]= seed64[1];
}
}
}
#ifdef __cplusplus
}
#endif
fortran-lang-stdlib-0ede301/test/hash_functions/waterhash.h 0000664 0001750 0001750 00000006440 15135654166 024323 0 ustar alastair alastair /*
Waterhash takes (optimally) 32-bit inputs and produces a 32-bit hash as its result.
It is an edited version of wyhash that uses at most 64-bit math instead of 128-bit.
It is meant to use very similar code to Wheathash, which produces a 64-bit hash.
Original Author: Wang Yi
Waterhash Variant Author: Tommy Ettinger
*/
#ifndef waterhash_version_3
#define waterhash_version_3
#include
#include
#include
const uint64_t _waterp0 = 0xa0761d65ull, _waterp1 = 0xe7037ed1ull, _waterp2 = 0x8ebc6af1ull;
const uint64_t _waterp3 = 0x589965cdull, _waterp4 = 0x1d8e4e27ull, _waterp5 = 0xeb44accbull;
static inline uint64_t _watermum(const uint64_t A, const uint64_t B) {
uint64_t r = A * B;
return r - (r >> 32);
}
static inline uint64_t _waterr08(const uint8_t *p){ uint8_t v; memcpy(&v, p, 1); return v; }
static inline uint64_t _waterr16(const uint8_t *p){ uint16_t v; memcpy(&v, p, 2); return v; }
static inline uint64_t _waterr32(const uint8_t *p){ uint32_t v; memcpy(&v, p, 4); return v; }
static inline uint32_t waterhash(const void* key, uint32_t len, uint64_t seed){
const uint8_t *p = (const uint8_t*)key;
uint32_t i;
for (i = 0; i + 16 <= len; i += 16, p += 16) {
seed = _watermum(
_watermum(_waterr32(p) ^ _waterp1, _waterr32(p + 4) ^ _waterp2) + seed,
_watermum(_waterr32(p + 8) ^ _waterp3, _waterr32(p + 12) ^ _waterp4));
}
seed += _waterp5;
switch (len & 15) {
case 1: seed = _watermum(_waterp2 ^ seed, _waterr08(p) ^ _waterp1); break;
case 2: seed = _watermum(_waterp3 ^ seed, _waterr16(p) ^ _waterp4); break;
case 3: seed = _watermum(_waterr16(p) ^ seed, _waterr08(p + 2) ^ _waterp2); break;
case 4: seed = _watermum(_waterr16(p) ^ seed, _waterr16(p + 2) ^ _waterp3); break;
case 5: seed = _watermum(_waterr32(p) ^ seed, _waterr08(p + 4) ^ _waterp1); break;
case 6: seed = _watermum(_waterr32(p) ^ seed, _waterr16(p + 4) ^ _waterp1); break;
case 7: seed = _watermum(_waterr32(p) ^ seed, (_waterr16(p + 4) << 8 | _waterr08(p + 6)) ^ _waterp1); break;
case 8: seed = _watermum(_waterr32(p) ^ seed, _waterr32(p + 4) ^ _waterp0); break;
case 9: seed = _watermum(_waterr32(p) ^ seed, _waterr32(p + 4) ^ _waterp2) ^ _watermum(seed ^ _waterp4, _waterr08(p + 8) ^ _waterp3); break;
case 10: seed = _watermum(_waterr32(p) ^ seed, _waterr32(p + 4) ^ _waterp2) ^ _watermum(seed, _waterr16(p + 8) ^ _waterp3); break;
case 11: seed = _watermum(_waterr32(p) ^ seed, _waterr32(p + 4) ^ _waterp2) ^ _watermum(seed, ((_waterr16(p + 8) << 8) | _waterr08(p + 10)) ^ _waterp3); break;
case 12: seed = _watermum(_waterr32(p) ^ seed, _waterr32(p + 4) ^ _waterp2) ^ _watermum(seed ^ _waterr32(p + 8), _waterp4); break;
case 13: seed = _watermum(_waterr32(p) ^ seed, _waterr32(p + 4) ^ _waterp2) ^ _watermum(seed ^ _waterr32(p + 8), (_waterr08(p + 12)) ^ _waterp4); break;
case 14: seed = _watermum(_waterr32(p) ^ seed, _waterr32(p + 4) ^ _waterp2) ^ _watermum(seed ^ _waterr32(p + 8), (_waterr16(p + 12)) ^ _waterp4); break;
case 15: seed = _watermum(_waterr32(p) ^ seed, _waterr32(p + 4) ^ _waterp2) ^ _watermum(seed ^ _waterr32(p + 8), (_waterr16(p + 12) << 8 | _waterr08(p + 14)) ^ _waterp4); break;
}
seed = (seed ^ seed << 16) * (len ^ _waterp0);
return (uint32_t)(seed - (seed >> 32));
}
#endif
fortran-lang-stdlib-0ede301/test/hash_functions/waterhash.c 0000664 0001750 0001750 00000000213 15135654166 024306 0 ustar alastair alastair #include "waterhash.h"
int32_t waterhash_test ( const void * key, uint32_t len, uint64_t seed ) {
return waterhash (key, len, seed);
}
fortran-lang-stdlib-0ede301/test/hash_functions/nmhash.h 0000664 0001750 0001750 00000063203 15135654166 023613 0 ustar alastair alastair /*
* verification:
* NMHASH32:
* rurban/smhasher: 0x12A30553
* demerphq/smhasher: 0x3D8F6C47
* NMHASH32X:
* rurban/smhasher: 0xA8580227
* demerphq/smhasher: 0x40B451B3
*/
#ifdef __cplusplus
extern "C" {
#endif
#ifndef _nmhash_h_
#define _nmhash_h_
#define NMH_VERSION 2
#ifdef _MSC_VER
# pragma warning(push, 3)
#endif
#if defined(__cplusplus) && __cplusplus < 201103L
# define __STDC_CONSTANT_MACROS 1
#endif
#include
#include
#if defined(__GNUC__)
# if defined(__AVX2__)
# include
# elif defined(__SSE2__)
# include
# endif
#elif defined(_MSC_VER)
# include
#endif
#ifdef _MSC_VER
# pragma warning(pop)
#endif
#if (defined(__GNUC__) && (__GNUC__ >= 3)) \
|| (defined(__INTEL_COMPILER) && (__INTEL_COMPILER >= 800)) \
|| defined(__clang__)
# define NMH_likely(x) __builtin_expect(x, 1)
#else
# define NMH_likely(x) (x)
#endif
#if defined(__has_builtin)
# if __has_builtin(__builtin_rotateleft32) \
&& !(defined(__INTEL_COMPILER) && defined(__APPLE__))
# define NMH_rotl32 __builtin_rotateleft32 /* clang */
# endif
#endif
#if !defined(NMH_rotl32)
# if defined(_MSC_VER)
/* Note: although _rotl exists for minGW (GCC under windows), performance seems poor */
# define NMH_rotl32(x,r) _rotl(x,r)
# else
# define NMH_rotl32(x,r) (((x) << (r)) | ((x) >> (32 - (r))))
# endif
#endif
#if ((defined(sun) || defined(__sun)) && __cplusplus) /* Solaris includes __STDC_VERSION__ with C++. Tested with GCC 5.5 */
# define NMH_RESTRICT /* disable */
#elif defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L /* >= C99 */
# define NMH_RESTRICT restrict
#elif defined(__cplusplus) && (defined(__GNUC__) || defined(__clang__) || defined(__INTEL_COMPILER))
# define NMH_RESTRICT __restrict__
#elif defined(__cplusplus) && defined(_MSC_VER)
# define NMH_RESTRICT __restrict
#else
# define NMH_RESTRICT /* disable */
#endif
/* endian macros */
#ifndef NMHASH_LITTLE_ENDIAN
# if defined(_WIN32) || defined(__LITTLE_ENDIAN__) || defined(__x86_64__) || (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__) || defined(__SDCC)
# define NMHASH_LITTLE_ENDIAN 1
# elif defined(__BIG_ENDIAN__) || (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
# define NMHASH_LITTLE_ENDIAN 0
# else
# warning could not determine endianness! Falling back to little endian.
# define NMHASH_LITTLE_ENDIAN 1
# endif
#endif
/* vector macros */
#define NMH_SCALAR 0
#define NMH_SSE2 1
#define NMH_AVX2 2
#define NMH_AVX512 3
#ifndef NMH_VECTOR /* can be defined on command line */
# if defined(__AVX512BW__)
# define NMH_VECTOR NMH_AVX512 /* _mm512_mullo_epi16 requires AVX512BW */
# elif defined(__AVX2__)
# define NMH_VECTOR NMH_AVX2 /* add '-mno-avx256-split-unaligned-load' and '-mn-oavx256-split-unaligned-store' for gcc */
# elif defined(__SSE2__) || defined(_M_AMD64) || defined(_M_X64) || (defined(_M_IX86_FP) && (_M_IX86_FP == 2))
# define NMH_VECTOR NMH_SSE2
# else
# define NMH_VECTOR NMH_SCALAR
# endif
#endif
/* align macros */
#if defined (__STDC_VERSION__) && (__STDC_VERSION__ >= 201112L) /* C11+ */
# include
# define NMH_ALIGN(n) alignas(n)
#elif defined(__GNUC__)
# define NMH_ALIGN(n) __attribute__ ((aligned(n)))
#elif defined(_MSC_VER)
# define NMH_ALIGN(n) __declspec(align(n))
#else
# define NMH_ALIGN(n) /* disabled */
#endif
#if NMH_VECTOR > 0
# define NMH_ACC_ALIGN 64
#elif defined(__BIGGEST_ALIGNMENT__)
# define NMH_ACC_ALIGN __BIGGEST_ALIGNMENT__
#elif defined(__SDCC)
# define NMH_ACC_ALIGN 1
#else
# define NMH_ACC_ALIGN 16
#endif
/* constants */
/* primes from xxh */
#define NMH_PRIME32_1 UINT32_C(0x9E3779B1)
#define NMH_PRIME32_2 UINT32_C(0x85EBCA77)
#define NMH_PRIME32_3 UINT32_C(0xC2B2AE3D)
#define NMH_PRIME32_4 UINT32_C(0x27D4EB2F)
/*! Pseudorandom secret taken directly from FARSH. */
NMH_ALIGN(NMH_ACC_ALIGN) static const uint32_t NMH_ACC_INIT[32] = {
UINT32_C(0xB8FE6C39), UINT32_C(0x23A44BBE), UINT32_C(0x7C01812C), UINT32_C(0xF721AD1C),
UINT32_C(0xDED46DE9), UINT32_C(0x839097DB), UINT32_C(0x7240A4A4), UINT32_C(0xB7B3671F),
UINT32_C(0xCB79E64E), UINT32_C(0xCCC0E578), UINT32_C(0x825AD07D), UINT32_C(0xCCFF7221),
UINT32_C(0xB8084674), UINT32_C(0xF743248E), UINT32_C(0xE03590E6), UINT32_C(0x813A264C),
UINT32_C(0x3C2852BB), UINT32_C(0x91C300CB), UINT32_C(0x88D0658B), UINT32_C(0x1B532EA3),
UINT32_C(0x71644897), UINT32_C(0xA20DF94E), UINT32_C(0x3819EF46), UINT32_C(0xA9DEACD8),
UINT32_C(0xA8FA763F), UINT32_C(0xE39C343F), UINT32_C(0xF9DCBBC7), UINT32_C(0xC70B4F1D),
UINT32_C(0x8A51E04B), UINT32_C(0xCDB45931), UINT32_C(0xC89F7EC9), UINT32_C(0xD9787364),
};
#if defined(_MSC_VER) && _MSC_VER >= 1914
# pragma warning(push)
# pragma warning(disable: 5045)
#endif
#ifdef __SDCC
# define const
# pragma save
# pragma disable_warning 110
# pragma disable_warning 126
#endif
/* read functions */
static inline
uint32_t
NMH_readLE32(const void *const p)
{
uint32_t v;
memcpy(&v, p, 4);
# if (NMHASH_LITTLE_ENDIAN)
return v;
# elif defined(__GNUC__) || defined(__INTEL_COMPILER) || defined(__clang__)
return __builtin_bswap32(v);
# elif defined(_MSC_VER)
return _byteswap_ulong(v);
# else
return ((v >> 24) & 0xff) | ((v >> 8) & 0xff00) | ((v << 8) & 0xff0000) | ((v << 24) & 0xff000000);
# endif
}
static inline
uint16_t
NMH_readLE16(const void *const p)
{
uint16_t v;
memcpy(&v, p, 2);
# if (NMHASH_LITTLE_ENDIAN)
return v;
# else
return (uint16_t)((v << 8) | (v >> 8));
# endif
}
static inline
uint32_t
NMHASH32_0to8(uint32_t const x, uint32_t const seed2)
{
/* base mixer: [-6 -12 776bf593 -19 11 3fb39c65 -15 -9 e9139917 -11 16] = 0.027071104091278835 */
const uint32_t m1 = UINT32_C(0x776BF593);
const uint32_t m2 = UINT32_C(0x3FB39C65);
const uint32_t m3 = UINT32_C(0xE9139917);
# if NMH_VECTOR == NMH_SCALAR
{
union { uint32_t u32; uint16_t u16[2]; } vx;
vx.u32 = x;
vx.u32 ^= (vx.u32 >> 12) ^ (vx.u32 >> 6);
vx.u16[0] *= (uint16_t)m1;
vx.u16[1] *= (uint16_t)(m1 >> 16);
vx.u32 ^= (vx.u32 << 11) ^ ( vx.u32 >> 19);
vx.u16[0] *= (uint16_t)m2;
vx.u16[1] *= (uint16_t)(m2 >> 16);
vx.u32 ^= seed2;
vx.u32 ^= (vx.u32 >> 15) ^ ( vx.u32 >> 9);
vx.u16[0] *= (uint16_t)m3;
vx.u16[1] *= (uint16_t)(m3 >> 16);
vx.u32 ^= (vx.u32 << 16) ^ ( vx.u32 >> 11);
return vx.u32;
}
# else /* at least NMH_SSE2 */
{
__m128i hv = _mm_setr_epi32((int)x, 0, 0, 0);
const __m128i sv = _mm_setr_epi32((int)seed2, 0, 0, 0);
const uint32_t *const result = (const uint32_t*)&hv;
hv = _mm_xor_si128(_mm_xor_si128(hv, _mm_srli_epi32(hv, 12)), _mm_srli_epi32(hv, 6));
hv = _mm_mullo_epi16(hv, _mm_setr_epi32((int)m1, 0, 0, 0));
hv = _mm_xor_si128(_mm_xor_si128(hv, _mm_slli_epi32(hv, 11)), _mm_srli_epi32(hv, 19));
hv = _mm_mullo_epi16(hv, _mm_setr_epi32((int)m2, 0, 0, 0));
hv = _mm_xor_si128(hv, sv);
hv = _mm_xor_si128(_mm_xor_si128(hv, _mm_srli_epi32(hv, 15)), _mm_srli_epi32(hv, 9));
hv = _mm_mullo_epi16(hv, _mm_setr_epi32((int)m3, 0, 0, 0));
hv = _mm_xor_si128(_mm_xor_si128(hv, _mm_slli_epi32(hv, 16)), _mm_srli_epi32(hv, 11));
return *result;
}
# endif
}
#define __NMH_M1 UINT32_C(0xF0D9649B)
#define __NMH_M2 UINT32_C(0x29A7935D)
#define __NMH_M3 UINT32_C(0x55D35831)
NMH_ALIGN(NMH_ACC_ALIGN) static const uint32_t __NMH_M1_V[32] = {
__NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1,
__NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1,
__NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1,
__NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1, __NMH_M1,
};
NMH_ALIGN(NMH_ACC_ALIGN) static const uint32_t __NMH_M2_V[32] = {
__NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2,
__NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2,
__NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2,
__NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2, __NMH_M2,
};
NMH_ALIGN(NMH_ACC_ALIGN) static const uint32_t __NMH_M3_V[32] = {
__NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3,
__NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3,
__NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3,
__NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3, __NMH_M3,
};
static inline
uint32_t
NMHASH32_9to255(const uint8_t* const NMH_RESTRICT p, size_t const len, uint32_t const seed, int const type)
{
/* base mixer: [f0d9649b 5 -13 29a7935d -9 11 55d35831 -20 -10 ] = 0.93495901789135362 */
uint32_t result = 0;
# if NMH_VECTOR == NMH_SCALAR
{
union { uint32_t u32; uint16_t u16[2]; } x[4], y[4];
uint32_t const sl = seed + (uint32_t)len;
size_t j;
x[0].u32 = NMH_PRIME32_1;
x[1].u32 = NMH_PRIME32_2;
x[2].u32 = NMH_PRIME32_3;
x[3].u32 = NMH_PRIME32_4;
for (j = 0; j < 4; ++j) y[j].u32 = sl;
if (type) {
/* 33 to 255 bytes */
size_t const r = (len - 1) / 32;
size_t i;
for (i = 0; i < r; ++i) {
for (j = 0; j < 4; ++j) x[j].u32 ^= NMH_readLE32(p + i * 32 + j * 4);
for (j = 0; j < 4; ++j) y[j].u32 ^= NMH_readLE32(p + i * 32 + j * 4 + 16);
for (j = 0; j < 4; ++j) x[j].u32 += y[j].u32;
for (j = 0; j < 4; ++j) {
x[j].u16[0] *= (uint16_t)(__NMH_M1 & 0xFFFF);
x[j].u16[1] *= (uint16_t)(__NMH_M1 >> 16);
}
for (j = 0; j < 4; ++j) x[j].u32 ^= (x[j].u32 << 5) ^ (x[j].u32 >> 13);
for (j = 0; j < 4; ++j) {
x[j].u16[0] *= (uint16_t)(__NMH_M2 & 0xFFFF);
x[j].u16[1] *= (uint16_t)(__NMH_M2 >> 16);
}
for (j = 0; j < 4; ++j) x[j].u32 ^= y[j].u32;
for (j = 0; j < 4; ++j) x[j].u32 ^= (x[j].u32 << 11) ^ (x[j].u32 >> 9);
for (j = 0; j < 4; ++j) {
x[j].u16[0] *= (uint16_t)(__NMH_M3 & 0xFFFF);
x[j].u16[1] *= (uint16_t)(__NMH_M3 >> 16);
}
for (j = 0; j < 4; ++j) x[j].u32 ^= (x[j].u32 >> 10) ^ (x[j].u32 >> 20);
}
for (j = 0; j < 4; ++j) x[j].u32 ^= NMH_readLE32(p + len - 32 + j * 4);
for (j = 0; j < 4; ++j) y[j].u32 ^= NMH_readLE32(p + len - 16 + j * 4);
} else {
/* 9 to 32 bytes */
x[0].u32 ^= NMH_readLE32(p);
x[1].u32 ^= NMH_readLE32(p + ((len>>4)<<3));
x[2].u32 ^= NMH_readLE32(p + len - 8);
x[3].u32 ^= NMH_readLE32(p + len - 8 - ((len>>4)<<3));
y[0].u32 ^= NMH_readLE32(p + 4);
y[1].u32 ^= NMH_readLE32(p + ((len>>4)<<3) + 4);
y[2].u32 ^= NMH_readLE32(p + len - 8 + 4);
y[3].u32 ^= NMH_readLE32(p + len - 8 - ((len>>4)<<3) + 4);
}
for (j = 0; j < 4; ++j) x[j].u32 += y[j].u32;
for (j = 0; j < 4; ++j) y[j].u32 ^= (y[j].u32 << 17) ^ (y[j].u32 >> 6);
for (j = 0; j < 4; ++j) {
x[j].u16[0] *= (uint16_t)(__NMH_M1 & 0xFFFF);
x[j].u16[1] *= (uint16_t)(__NMH_M1 >> 16);
}
for (j = 0; j < 4; ++j) x[j].u32 ^= (x[j].u32 << 5) ^ (x[j].u32 >> 13);
for (j = 0; j < 4; ++j) {
x[j].u16[0] *= (uint16_t)(__NMH_M2 & 0xFFFF);
x[j].u16[1] *= (uint16_t)(__NMH_M2 >> 16);
}
for (j = 0; j < 4; ++j) x[j].u32 ^= y[j].u32;
for (j = 0; j < 4; ++j) x[j].u32 ^= (x[j].u32 << 11) ^ (x[j].u32 >> 9);
for (j = 0; j < 4; ++j) {
x[j].u16[0] *= (uint16_t)(__NMH_M3 & 0xFFFF);
x[j].u16[1] *= (uint16_t)(__NMH_M3 >> 16);
}
for (j = 0; j < 4; ++j) x[j].u32 ^= (x[j].u32 >> 10) ^ (x[j].u32 >> 20);
x[0].u32 ^= NMH_PRIME32_1;
x[1].u32 ^= NMH_PRIME32_2;
x[2].u32 ^= NMH_PRIME32_3;
x[3].u32 ^= NMH_PRIME32_4;
for (j = 1; j < 4; ++j) x[0].u32 += x[j].u32;
x[0].u32 ^= sl + (sl >> 5);
x[0].u16[0] *= (uint16_t)(__NMH_M3 & 0xFFFF);
x[0].u16[1] *= (uint16_t)(__NMH_M3 >> 16);
x[0].u32 ^= (x[0].u32 >> 10) ^ (x[0].u32 >> 20);
result = x[0].u32;
}
# else /* at least NMH_SSE2 */
{
__m128i const h0 = _mm_setr_epi32((int)NMH_PRIME32_1, (int)NMH_PRIME32_2, (int)NMH_PRIME32_3, (int)NMH_PRIME32_4);
__m128i const sl = _mm_set1_epi32((int)seed + (int)len);
__m128i const m1 = _mm_set1_epi32((int)__NMH_M1);
__m128i const m2 = _mm_set1_epi32((int)__NMH_M2);
__m128i const m3 = _mm_set1_epi32((int)__NMH_M3);
__m128i x = h0;
__m128i y = sl;
const uint32_t *const px = (const uint32_t*)&x;
if (type) {
/* 32 to 127 bytes */
size_t const r = (len - 1) / 32;
size_t i;
for (i = 0; i < r; ++i) {
x = _mm_xor_si128(x, _mm_loadu_si128((const __m128i *)(p + i * 32)));
y = _mm_xor_si128(y, _mm_loadu_si128((const __m128i *)(p + i * 32 + 16)));
x = _mm_add_epi32(x, y);
x = _mm_mullo_epi16(x, m1);
x = _mm_xor_si128(_mm_xor_si128(x, _mm_slli_epi32(x, 5)), _mm_srli_epi32(x, 13));
x = _mm_mullo_epi16(x, m2);
x = _mm_xor_si128(x, y);
x = _mm_xor_si128(_mm_xor_si128(x, _mm_slli_epi32(x, 11)), _mm_srli_epi32(x, 9));
x = _mm_mullo_epi16(x, m3);
x = _mm_xor_si128(_mm_xor_si128(x, _mm_srli_epi32(x, 10)), _mm_srli_epi32(x, 20));
}
x = _mm_xor_si128(x, _mm_loadu_si128((const __m128i *)(p + len - 32)));
y = _mm_xor_si128(y, _mm_loadu_si128((const __m128i *)(p + len - 16)));
} else {
/* 9 to 32 bytes */
x = _mm_xor_si128(x, _mm_setr_epi32((int)NMH_readLE32(p), (int)NMH_readLE32(p + ((len>>4)<<3)), (int)NMH_readLE32(p + len - 8), (int)NMH_readLE32(p + len - 8 - ((len>>4)<<3))));
y = _mm_xor_si128(y, _mm_setr_epi32((int)NMH_readLE32(p + 4), (int)NMH_readLE32(p + ((len>>4)<<3) + 4), (int)NMH_readLE32(p + len - 8 + 4), (int)NMH_readLE32(p + len - 8 - ((len>>4)<<3) + 4)));
}
x = _mm_add_epi32(x, y);
y = _mm_xor_si128(_mm_xor_si128(y, _mm_slli_epi32(y, 17)), _mm_srli_epi32(y, 6));
x = _mm_mullo_epi16(x, m1);
x = _mm_xor_si128(_mm_xor_si128(x, _mm_slli_epi32(x, 5)), _mm_srli_epi32(x, 13));
x = _mm_mullo_epi16(x, m2);
x = _mm_xor_si128(x, y);
x = _mm_xor_si128(_mm_xor_si128(x, _mm_slli_epi32(x, 11)), _mm_srli_epi32(x, 9));
x = _mm_mullo_epi16(x, m3);
x = _mm_xor_si128(_mm_xor_si128(x, _mm_srli_epi32(x, 10)), _mm_srli_epi32(x, 20));
x = _mm_xor_si128(x, h0);
x = _mm_add_epi32(x, _mm_srli_si128(x, 4));
x = _mm_add_epi32(x, _mm_srli_si128(x, 8));
x = _mm_xor_si128(x, _mm_add_epi32(sl, _mm_srli_epi32(sl, 5)));
x = _mm_mullo_epi16(x, m3);
x = _mm_xor_si128(_mm_xor_si128(x, _mm_srli_epi32(x, 10)), _mm_srli_epi32(x, 20));
result = *px;
}
# endif
return *&result;
}
#define NMHASH32_9to32(p, len, seed) NMHASH32_9to255(p, len, seed, 0)
#define NMHASH32_33to255(p, len, seed) NMHASH32_9to255(p, len, seed, 1)
#undef __NMH_M1
#undef __NMH_M2
#undef __NMH_M3
#if NMH_VECTOR == NMH_SCALAR
#define NMHASH32_long_round NMHASH32_long_round_scalar
static inline
void
NMHASH32_long_round_scalar(uint32_t *const NMH_RESTRICT accX, uint32_t *const NMH_RESTRICT accY, const uint8_t* const NMH_RESTRICT p)
{
/* breadth first calculation will hint some compiler to auto vectorize the code
* on gcc, the performance becomes 10x than the depth first, and about 80% of the manually vectorized code
*/
const size_t nbGroups = sizeof(NMH_ACC_INIT) / sizeof(*NMH_ACC_INIT);
size_t i;
for (i = 0; i < nbGroups; ++i) {
accX[i] ^= NMH_readLE32(p + i * 4);
}
for (i = 0; i < nbGroups; ++i) {
accY[i] ^= NMH_readLE32(p + i * 4 + sizeof(NMH_ACC_INIT));
}
for (i = 0; i < nbGroups; ++i) {
accX[i] += accY[i];
}
for (i = 0; i < nbGroups; ++i) {
accY[i] ^= accX[i] >> 1;
}
for (i = 0; i < nbGroups * 2; ++i) {
((uint16_t*)accX)[i] *= ((uint16_t*)__NMH_M1_V)[i];
}
for (i = 0; i < nbGroups; ++i) {
accX[i] ^= accX[i] << 5 ^ accX[i] >> 13;
}
for (i = 0; i < nbGroups * 2; ++i) {
((uint16_t*)accX)[i] *= ((uint16_t*)__NMH_M2_V)[i];
}
for (i = 0; i < nbGroups; ++i) {
accX[i] ^= accY[i];
}
for (i = 0; i < nbGroups; ++i) {
accX[i] ^= accX[i] << 11 ^ accX[i] >> 9;
}
for (i = 0; i < nbGroups * 2; ++i) {
((uint16_t*)accX)[i] *= ((uint16_t*)__NMH_M3_V)[i];
}
for (i = 0; i < nbGroups; ++i) {
accX[i] ^= accX[i] >> 10 ^ accX[i] >> 20;
}
}
#endif
#if NMH_VECTOR == NMH_SSE2
# define _NMH_MM_(F) _mm_ ## F
# define _NMH_MMW_(F) _mm_ ## F ## 128
# define _NMH_MM_T __m128i
#elif NMH_VECTOR == NMH_AVX2
# define _NMH_MM_(F) _mm256_ ## F
# define _NMH_MMW_(F) _mm256_ ## F ## 256
# define _NMH_MM_T __m256i
#elif NMH_VECTOR == NMH_AVX512
# define _NMH_MM_(F) _mm512_ ## F
# define _NMH_MMW_(F) _mm512_ ## F ## 512
# define _NMH_MM_T __m512i
#endif
#if NMH_VECTOR == NMH_SSE2 || NMH_VECTOR == NMH_AVX2 || NMH_VECTOR == NMH_AVX512
# define NMHASH32_long_round NMHASH32_long_round_sse
# define NMH_VECTOR_NB_GROUP (sizeof(NMH_ACC_INIT) / sizeof(*NMH_ACC_INIT) / (sizeof(_NMH_MM_T) / sizeof(*NMH_ACC_INIT)))
static inline
void
NMHASH32_long_round_sse(uint32_t *const NMH_RESTRICT accX, uint32_t *const NMH_RESTRICT accY, const uint8_t* const NMH_RESTRICT p)
{
const _NMH_MM_T *const NMH_RESTRICT m1 = (const _NMH_MM_T * NMH_RESTRICT)__NMH_M1_V;
const _NMH_MM_T *const NMH_RESTRICT m2 = (const _NMH_MM_T * NMH_RESTRICT)__NMH_M2_V;
const _NMH_MM_T *const NMH_RESTRICT m3 = (const _NMH_MM_T * NMH_RESTRICT)__NMH_M3_V;
_NMH_MM_T *const xaccX = ( _NMH_MM_T * )accX;
_NMH_MM_T *const xaccY = ( _NMH_MM_T * )accY;
_NMH_MM_T *const xp = ( _NMH_MM_T * )p;
size_t i;
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MMW_(xor_si)(xaccX[i], _NMH_MMW_(loadu_si)(xp + i));
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccY[i] = _NMH_MMW_(xor_si)(xaccY[i], _NMH_MMW_(loadu_si)(xp + i + NMH_VECTOR_NB_GROUP));
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MM_(add_epi32)(xaccX[i], xaccY[i]);
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccY[i] = _NMH_MMW_(xor_si)(xaccY[i], _NMH_MM_(srli_epi32)(xaccX[i], 1));
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MM_(mullo_epi16)(xaccX[i], *m1);
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MMW_(xor_si)(_NMH_MMW_(xor_si)(xaccX[i], _NMH_MM_(slli_epi32)(xaccX[i], 5)), _NMH_MM_(srli_epi32)(xaccX[i], 13));
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MM_(mullo_epi16)(xaccX[i], *m2);
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MMW_(xor_si)(xaccX[i], xaccY[i]);
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MMW_(xor_si)(_NMH_MMW_(xor_si)(xaccX[i], _NMH_MM_(slli_epi32)(xaccX[i], 11)), _NMH_MM_(srli_epi32)(xaccX[i], 9));
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MM_(mullo_epi16)(xaccX[i], *m3);
}
for (i = 0; i < NMH_VECTOR_NB_GROUP; ++i) {
xaccX[i] = _NMH_MMW_(xor_si)(_NMH_MMW_(xor_si)(xaccX[i], _NMH_MM_(srli_epi32)(xaccX[i], 10)), _NMH_MM_(srli_epi32)(xaccX[i], 20));
}
}
# undef _NMH_MM_
# undef _NMH_MMW_
# undef _NMH_MM_T
# undef NMH_VECTOR_NB_GROUP
#endif
static
uint32_t
NMHASH32_long(const uint8_t* const NMH_RESTRICT p, size_t const len, uint32_t const seed)
{
NMH_ALIGN(NMH_ACC_ALIGN) uint32_t accX[sizeof(NMH_ACC_INIT)/sizeof(*NMH_ACC_INIT)];
NMH_ALIGN(NMH_ACC_ALIGN) uint32_t accY[sizeof(accX)/sizeof(*accX)];
size_t const nbRounds = (len - 1) / (sizeof(accX) + sizeof(accY));
size_t i;
uint32_t sum = 0;
/* init */
for (i = 0; i < sizeof(accX)/sizeof(*accX); ++i) accX[i] = NMH_ACC_INIT[i];
for (i = 0; i < sizeof(accY)/sizeof(*accY); ++i) accY[i] = seed;
for (i = 0; i < nbRounds; ++i) {
NMHASH32_long_round(accX, accY, p + i * (sizeof(accX) + sizeof(accY)));
}
NMHASH32_long_round(accX, accY, p + len - (sizeof(accX) + sizeof(accY)));
/* merge acc */
for (i = 0; i < sizeof(accX)/sizeof(*accX); ++i) accX[i] ^= NMH_ACC_INIT[i];
for (i = 0; i < sizeof(accX)/sizeof(*accX); ++i) sum += accX[i];
# if SIZE_MAX > UINT32_C(-1)
sum += (uint32_t)(len >> 32);
# endif
return sum ^ (uint32_t)len;
}
static inline
uint32_t
NMHASH32_avalanche32(uint32_t const x)
{
/* [-21 -8 cce5196d 12 -7 464be229 -21 -8] = 3.2267098842182733 */
const uint32_t m1 = UINT32_C(0xCCE5196D);
const uint32_t m2 = UINT32_C(0x464BE229);
union { uint32_t u32; uint16_t u16[2]; } vx;
vx.u32 = x;
vx.u32 ^= (vx.u32 >> 8) ^ (vx.u32 >> 21);
vx.u16[0] = (uint16_t)(vx.u16[0] * (uint16_t)m1);
vx.u16[1] = (uint16_t)(vx.u16[1] * (uint16_t)(m1 >> 16));
vx.u32 ^= (vx.u32 << 12) ^ (vx.u32 >> 7);
vx.u16[0] = (uint16_t)(vx.u16[0] * (uint16_t)m2);
vx.u16[1] = (uint16_t)(vx.u16[1] * (uint16_t)(m2 >> 16));
return vx.u32 ^ (vx.u32 >> 8) ^ (vx.u32 >> 21);
}
static inline
uint32_t
NMHASH32(const void* const NMH_RESTRICT input, size_t const len, uint32_t seed)
{
const uint8_t *const p = (const uint8_t *)input;
if (NMH_likely(len <= 32)) {
if(NMH_likely(len > 8)) {
return NMHASH32_9to32(p, len, seed);
}
if(NMH_likely(len > 4)) {
uint32_t x = NMH_readLE32(p);
uint32_t y = NMH_readLE32(p + len - 4) ^ (NMH_PRIME32_4 + 2 + seed);
x += y;
x ^= x << (len + 7);
return NMHASH32_0to8(x, NMH_rotl32(y, 5));
} else {
union { uint32_t u32; uint16_t u16[2]; uint8_t u8[4]; } data;
switch (len) {
case 0: seed += NMH_PRIME32_2;
data.u32 = 0;
break;
case 1: seed += NMH_PRIME32_2 + (UINT32_C(1) << 24) + (1 << 1);
data.u32 = p[0];
break;
case 2: seed += NMH_PRIME32_2 + (UINT32_C(2) << 24) + (2 << 1);
data.u32 = NMH_readLE16(p);
break;
case 3: seed += NMH_PRIME32_2 + (UINT32_C(3) << 24) + (3 << 1);
data.u16[1] = p[2];
data.u16[0] = NMH_readLE16(p);
break;
case 4: seed += NMH_PRIME32_3;
data.u32 = NMH_readLE32(p);
break;
default: return 0;
}
return NMHASH32_0to8(data.u32 + seed, NMH_rotl32(seed, 5));
}
}
if (NMH_likely(len < 256)) {
return NMHASH32_33to255(p, len, seed);
}
return NMHASH32_avalanche32(NMHASH32_long(p, len, seed));
}
static inline
uint32_t
NMHASH32X_0to4(uint32_t x, uint32_t const seed)
{
/* [bdab1ea9 18 a7896a1b 12 83796a2d 16] = 0.092922873297662509 */
x ^= seed;
x *= UINT32_C(0xBDAB1EA9);
x += NMH_rotl32(seed, 31);
x ^= x >> 18;
x *= UINT32_C(0xA7896A1B);
x ^= x >> 12;
x *= UINT32_C(0x83796A2D);
x ^= x >> 16;
return x;
}
static inline
uint32_t
NMHASH32X_5to8(const uint8_t* const NMH_RESTRICT p, size_t const len, uint32_t const seed)
{
/* - 5 to 9 bytes
* - mixer: [11049a7d 23 bcccdc7b 12 065e9dad 12] = 0.16577596555667246 */
uint32_t x = NMH_readLE32(p) ^ NMH_PRIME32_3;
uint32_t const y = NMH_readLE32(p + len - 4) ^ seed;
x += y;
x ^= x >> len;
x *= UINT32_C(0x11049A7D);
x ^= x >> 23;
x *= UINT32_C(0xBCCCDC7B);
x ^= NMH_rotl32(y, 3);
x ^= x >> 12;
x *= UINT32_C(0x065E9DAD);
x ^= x >> 12;
return x;
}
static inline
uint32_t
NMHASH32X_9to255(const uint8_t* const NMH_RESTRICT p, size_t const len, uint32_t const seed)
{
/* - at least 9 bytes
* - base mixer: [11049a7d 23 bcccdc7b 12 065e9dad 12] = 0.16577596555667246
* - tail mixer: [16 a52fb2cd 15 551e4d49 16] = 0.17162579707098322
*/
uint32_t x = NMH_PRIME32_3;
uint32_t y = seed;
uint32_t a = NMH_PRIME32_4;
uint32_t b = seed;
size_t i, r = (len - 1) / 16;
for (i = 0; i < r; ++i) {
x ^= NMH_readLE32(p + i * 16 + 0);
y ^= NMH_readLE32(p + i * 16 + 4);
x ^= y;
x *= UINT32_C(0x11049A7D);
x ^= x >> 23;
x *= UINT32_C(0xBCCCDC7B);
y = NMH_rotl32(y, 4);
x ^= y;
x ^= x >> 12;
x *= UINT32_C(0x065E9DAD);
x ^= x >> 12;
a ^= NMH_readLE32(p + i * 16 + 8);
b ^= NMH_readLE32(p + i * 16 + 12);
a ^= b;
a *= UINT32_C(0x11049A7D);
a ^= a >> 23;
a *= UINT32_C(0xBCCCDC7B);
b = NMH_rotl32(b, 3);
a ^= b;
a ^= a >> 12;
a *= UINT32_C(0x065E9DAD);
a ^= a >> 12;
}
if (NMH_likely(((uint8_t)len-1) & 8)) {
if (NMH_likely(((uint8_t)len-1) & 4)) {
a ^= NMH_readLE32(p + r * 16 + 0);
b ^= NMH_readLE32(p + r * 16 + 4);
a ^= b;
a *= UINT32_C(0x11049A7D);
a ^= a >> 23;
a *= UINT32_C(0xBCCCDC7B);
a ^= NMH_rotl32(b, 4);
a ^= a >> 12;
a *= UINT32_C(0x065E9DAD);
} else {
a ^= NMH_readLE32(p + r * 16) + b;
a ^= a >> 16;
a *= UINT32_C(0xA52FB2CD);
a ^= a >> 15;
a *= UINT32_C(0x551E4D49);
}
x ^= NMH_readLE32(p + len - 8);
y ^= NMH_readLE32(p + len - 4);
x ^= y;
x *= UINT32_C(0x11049A7D);
x ^= x >> 23;
x *= UINT32_C(0xBCCCDC7B);
x ^= NMH_rotl32(y, 3);
x ^= x >> 12;
x *= UINT32_C(0x065E9DAD);
} else {
if (NMH_likely(((uint8_t)len-1) & 4)) {
a ^= NMH_readLE32(p + r * 16) + b;
a ^= a >> 16;
a *= UINT32_C(0xA52FB2CD);
a ^= a >> 15;
a *= UINT32_C(0x551E4D49);
}
x ^= NMH_readLE32(p + len - 4) + y;
x ^= x >> 16;
x *= UINT32_C(0xA52FB2CD);
x ^= x >> 15;
x *= UINT32_C(0x551E4D49);
}
x ^= (uint32_t)len;
x ^= NMH_rotl32(a, 27); /* rotate one lane to pass Diff test */
x ^= x >> 14;
x *= UINT32_C(0x141CC535);
return x;
}
static inline
uint32_t
NMHASH32X_avalanche32(uint32_t x)
{
/* mixer with 2 mul from skeeto/hash-prospector:
* [15 d168aaad 15 af723597 15] = 0.15983776156606694
*/
x ^= x >> 15;
x *= UINT32_C(0xD168AAAD);
x ^= x >> 15;
x *= UINT32_C(0xAF723597);
x ^= x >> 15;
return x;
}
/* use 32*32->32 multiplication for short hash */
static inline
uint32_t
NMHASH32X(const void* const NMH_RESTRICT input, size_t const len, uint32_t seed)
{
const uint8_t *const p = (const uint8_t *)input;
if (NMH_likely(len <= 8)) {
if (NMH_likely(len > 4)) {
return NMHASH32X_5to8(p, len, seed);
} else {
/* 0-4 bytes */
union { uint32_t u32; uint16_t u16[2]; uint8_t u8[4]; } data;
switch (len) {
case 0: seed += NMH_PRIME32_2;
data.u32 = 0;
break;
case 1: seed += NMH_PRIME32_2 + (UINT32_C(1) << 24) + (1 << 1);
data.u32 = p[0];
break;
case 2: seed += NMH_PRIME32_2 + (UINT32_C(2) << 24) + (2 << 1);
data.u32 = NMH_readLE16(p);
break;
case 3: seed += NMH_PRIME32_2 + (UINT32_C(3) << 24) + (3 << 1);
data.u16[1] = p[2];
data.u16[0] = NMH_readLE16(p);
break;
case 4: seed += NMH_PRIME32_1;
data.u32 = NMH_readLE32(p);
break;
default: return 0;
}
return NMHASH32X_0to4(data.u32, seed);
}
}
if (NMH_likely(len < 256)) {
return NMHASH32X_9to255(p, len, seed);
}
return NMHASH32X_avalanche32(NMHASH32_long(p, len, seed));
}
#if defined(_MSC_VER) && _MSC_VER >= 1914
# pragma warning(pop)
#endif
#ifdef __SDCC
# pragma restore
# undef const
#endif
#endif /* _nmhash_h_ */
#ifdef __cplusplus
}
#endif
fortran-lang-stdlib-0ede301/test/hash_functions/SpookyV2.cpp 0000664 0001750 0001750 00000020521 15135654166 024360 0 ustar alastair alastair // Spooky Hash
// A 128-bit noncryptographic hash, for checksums and table lookup
// By Bob Jenkins. Public domain.
// Oct 31 2010: published framework, disclaimer ShortHash isn't right
// Nov 7 2010: disabled ShortHash
// Oct 31 2011: replace End, ShortMix, ShortEnd, enable ShortHash again
// April 10 2012: buffer overflow on platforms without unaligned reads
// July 12 2012: was passing out variables in final to in/out in short
// July 30 2012: I reintroduced the buffer overflow
// August 5 2012: SpookyV2: d = should be d += in short hash, and remove extra mix from long hash
#include
#include "SpookyV2.h"
#define ALLOW_UNALIGNED_READS 1
//
// short hash ... it could be used on any message,
// but it's used by Spooky just for short messages.
//
void SpookyHash::Short(
const void *message,
size_t length,
uint64 *hash1,
uint64 *hash2)
{
uint64 buf[2*sc_numVars];
union
{
const uint8 *p8;
uint32 *p32;
uint64 *p64;
size_t i;
} u;
u.p8 = (const uint8 *)message;
if (!ALLOW_UNALIGNED_READS && (u.i & 0x7))
{
memcpy(buf, message, length);
u.p64 = buf;
}
size_t remainder = length%32;
uint64 a=*hash1;
uint64 b=*hash2;
uint64 c=sc_const;
uint64 d=sc_const;
if (length > 15)
{
const uint64 *end = u.p64 + (length/32)*4;
// handle all complete sets of 32 bytes
for (; u.p64 < end; u.p64 += 4)
{
c += u.p64[0];
d += u.p64[1];
ShortMix(a,b,c,d);
a += u.p64[2];
b += u.p64[3];
}
//Handle the case of 16+ remaining bytes.
if (remainder >= 16)
{
c += u.p64[0];
d += u.p64[1];
ShortMix(a,b,c,d);
u.p64 += 2;
remainder -= 16;
}
}
// Handle the last 0..15 bytes, and its length
d += ((uint64)length) << 56;
switch (remainder)
{
case 15:
d += ((uint64)u.p8[14]) << 48;
case 14:
d += ((uint64)u.p8[13]) << 40;
case 13:
d += ((uint64)u.p8[12]) << 32;
case 12:
d += u.p32[2];
c += u.p64[0];
break;
case 11:
d += ((uint64)u.p8[10]) << 16;
case 10:
d += ((uint64)u.p8[9]) << 8;
case 9:
d += (uint64)u.p8[8];
case 8:
c += u.p64[0];
break;
case 7:
c += ((uint64)u.p8[6]) << 48;
case 6:
c += ((uint64)u.p8[5]) << 40;
case 5:
c += ((uint64)u.p8[4]) << 32;
case 4:
c += u.p32[0];
break;
case 3:
c += ((uint64)u.p8[2]) << 16;
case 2:
c += ((uint64)u.p8[1]) << 8;
case 1:
c += (uint64)u.p8[0];
break;
case 0:
c += sc_const;
d += sc_const;
}
ShortEnd(a,b,c,d);
*hash1 = a;
*hash2 = b;
}
// do the whole hash in one call
void SpookyHash::Hash128(
const void *message,
size_t length,
uint64 *hash1,
uint64 *hash2)
{
if (length < sc_bufSize)
{
Short(message, length, hash1, hash2);
return;
}
uint64 h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11;
uint64 buf[sc_numVars];
uint64 *end;
union
{
const uint8 *p8;
uint64 *p64;
size_t i;
} u;
size_t remainder;
h0=h3=h6=h9 = *hash1;
h1=h4=h7=h10 = *hash2;
h2=h5=h8=h11 = sc_const;
u.p8 = (const uint8 *)message;
end = u.p64 + (length/sc_blockSize)*sc_numVars;
// handle all whole sc_blockSize blocks of bytes
if (ALLOW_UNALIGNED_READS || ((u.i & 0x7) == 0))
{
while (u.p64 < end)
{
Mix(u.p64, h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
u.p64 += sc_numVars;
}
}
else
{
while (u.p64 < end)
{
memcpy(buf, u.p64, sc_blockSize);
Mix(buf, h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
u.p64 += sc_numVars;
}
}
// handle the last partial block of sc_blockSize bytes
remainder = (length - ((const uint8 *)end-(const uint8 *)message));
memcpy(buf, end, remainder);
memset(((uint8 *)buf)+remainder, 0, sc_blockSize-remainder);
((uint8 *)buf)[sc_blockSize-1] = remainder;
// do some final mixing
End(buf, h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
*hash1 = h0;
*hash2 = h1;
}
// init spooky state
void SpookyHash::Init(uint64 seed1, uint64 seed2)
{
m_length = 0;
m_remainder = 0;
m_state[0] = seed1;
m_state[1] = seed2;
}
// add a message fragment to the state
void SpookyHash::Update(const void *message, size_t length)
{
uint64 h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11;
size_t newLength = length + m_remainder;
uint8 remainder;
union
{
const uint8 *p8;
uint64 *p64;
size_t i;
} u;
const uint64 *end;
// Is this message fragment too short? If it is, stuff it away.
if (newLength < sc_bufSize)
{
memcpy(&((uint8 *)m_data)[m_remainder], message, length);
m_length = length + m_length;
m_remainder = (uint8)newLength;
return;
}
// init the variables
if (m_length < sc_bufSize)
{
h0=h3=h6=h9 = m_state[0];
h1=h4=h7=h10 = m_state[1];
h2=h5=h8=h11 = sc_const;
}
else
{
h0 = m_state[0];
h1 = m_state[1];
h2 = m_state[2];
h3 = m_state[3];
h4 = m_state[4];
h5 = m_state[5];
h6 = m_state[6];
h7 = m_state[7];
h8 = m_state[8];
h9 = m_state[9];
h10 = m_state[10];
h11 = m_state[11];
}
m_length = length + m_length;
// if we've got anything stuffed away, use it now
if (m_remainder)
{
uint8 prefix = sc_bufSize-m_remainder;
memcpy(&(((uint8 *)m_data)[m_remainder]), message, prefix);
u.p64 = m_data;
Mix(u.p64, h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
Mix(&u.p64[sc_numVars], h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
u.p8 = ((const uint8 *)message) + prefix;
length -= prefix;
}
else
{
u.p8 = (const uint8 *)message;
}
// handle all whole blocks of sc_blockSize bytes
end = u.p64 + (length/sc_blockSize)*sc_numVars;
remainder = (uint8)(length-((const uint8 *)end-u.p8));
if (ALLOW_UNALIGNED_READS || (u.i & 0x7) == 0)
{
while (u.p64 < end)
{
Mix(u.p64, h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
u.p64 += sc_numVars;
}
}
else
{
while (u.p64 < end)
{
memcpy(m_data, u.p8, sc_blockSize);
Mix(m_data, h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
u.p64 += sc_numVars;
}
}
// stuff away the last few bytes
m_remainder = remainder;
memcpy(m_data, end, remainder);
// stuff away the variables
m_state[0] = h0;
m_state[1] = h1;
m_state[2] = h2;
m_state[3] = h3;
m_state[4] = h4;
m_state[5] = h5;
m_state[6] = h6;
m_state[7] = h7;
m_state[8] = h8;
m_state[9] = h9;
m_state[10] = h10;
m_state[11] = h11;
}
// report the hash for the concatenation of all message fragments so far
void SpookyHash::Final(uint64 *hash1, uint64 *hash2)
{
// init the variables
if (m_length < sc_bufSize)
{
*hash1 = m_state[0];
*hash2 = m_state[1];
Short( m_data, m_length, hash1, hash2);
return;
}
const uint64 *data = (const uint64 *)m_data;
uint8 remainder = m_remainder;
uint64 h0 = m_state[0];
uint64 h1 = m_state[1];
uint64 h2 = m_state[2];
uint64 h3 = m_state[3];
uint64 h4 = m_state[4];
uint64 h5 = m_state[5];
uint64 h6 = m_state[6];
uint64 h7 = m_state[7];
uint64 h8 = m_state[8];
uint64 h9 = m_state[9];
uint64 h10 = m_state[10];
uint64 h11 = m_state[11];
if (remainder >= sc_blockSize)
{
// m_data can contain two blocks; handle any whole first block
Mix(data, h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
data += sc_numVars;
remainder -= sc_blockSize;
}
// mix in the last partial block, and the length mod sc_blockSize
memset(&((uint8 *)data)[remainder], 0, (sc_blockSize-remainder));
((uint8 *)data)[sc_blockSize-1] = remainder;
// do some final mixing
End(data, h0,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11);
*hash1 = h0;
*hash2 = h1;
}
fortran-lang-stdlib-0ede301/test/hash_functions/pengyhash.h 0000664 0001750 0001750 00000000233 15135654166 024315 0 ustar alastair alastair #ifndef _PENGYHASH_H
#define _PENGYHASH_H
#include
#include
uint64_t pengyhash(const void *p, size_t size, uint32_t seed);
#endif
fortran-lang-stdlib-0ede301/test/hash_functions/generate_hash_arrays.cpp 0000664 0001750 0001750 00000011365 15135654166 027050 0 ustar alastair alastair #include
#include
extern "C" {
#include "nmhash.h"
#include "pengyhash.h"
#include "waterhash.h"
int generate_all_c_hash();
}
#include "SpookyV2.h"
void SpookyHash32_with_state_test(const void *key, size_t len, const void *state, void *out) {
uint64_t *state64= (uint64_t *)state;
uint64_t s0 = state64[0];
uint64_t s1 = state64[1];
SpookyHash::Hash128(key, len, &s0, &s1);
((uint32_t *)out)[0]= (uint32_t)s0;
}
void SpookyHash64_with_state_test(const void *key, size_t len, const void *state, void *out) {
uint64_t *state64= (uint64_t *)state;
uint64_t *out64= (uint64_t *)out;
out64[0] = state64[0];
uint64_t s1 = state64[1];
SpookyHash::Hash128(key, len, out64, &s1);
}
void SpookyHash128_with_state_test(const void *key, size_t len, const void *state, void *out) {
uint64_t *state64= (uint64_t *)state;
uint64_t *out64= (uint64_t *)out;
out64[0] = state64[0];
out64[1] = state64[1];
SpookyHash::Hash128(key, len, out64, out64+1);
}
void SpookyHash_seed_state_test(int in_bits, const void *seed, void *state) {
uint64_t *state64= (uint64_t *)state;
if (in_bits == 32) {
state64[0]= state64[1]= ((uint32_t*)seed)[0];
}
else {
uint64_t *seed64= (uint64_t *)seed;
if (in_bits == 64) {
state64[0]= state64[1]= seed64[0];
}
else
if (in_bits == 128) {
state64[0]= seed64[0];
state64[1]= seed64[1];
}
}
}
using namespace std;
static const int SIZE = 2048;
char * key_array = new char[SIZE];
static const uint32_t NM_SEED = 0xdeadbeef;
static const uint64_t WATER_SEED = 0xdeadbeef1eadbeef;
static const uint32_t PENGY_SEED = 0xdeadbeef;
static const uint64_t SPOOKY_SEED[2] = { WATER_SEED, WATER_SEED };
int read_keys(){
string inFileName = "key_array.bin";
std::ifstream fin( inFileName, ios::in | ios::binary );
if (!fin){
cout << "Cannot open key_array.bin!" << endl;
return 1;
}
fin.read(key_array, SIZE);
fin.close();
return 0;
}
int write_nmhash32(){
size_t i;
uint32_t hash;
string outFileName = "c_nmhash32_array.bin";
std::ofstream fout( outFileName, ios::out | ios::binary );
if (!fout){
cout << "Cannot open c_nmhash32_array.bin!" << endl;
return 1;
}
for( i=0; i<=SIZE; i+=1 ){
hash = NMHASH32((void *) key_array, i, NM_SEED);
fout.write((char *) &hash, 4);
}
fout.close();
return 0;
}
int write_nmhash32x(){
size_t i;
uint32_t hash;
string outFileName = "c_nmhash32x_array.bin";
std::ofstream fout( outFileName, ios::out | ios::binary );
if (!fout){
cout << "Cannot open c_nmhash32x_array.bin!" << endl;
return 1;
}
for( i=0; i<=SIZE; i+=1 ){
hash = NMHASH32X((void *) key_array, i, NM_SEED);
fout.write((char *) &hash, 4);
}
fout.close();
return 0;
}
int write_water(){
uint32_t i;
uint32_t hash;
string outFileName = "c_water_hash_array.bin";
std::ofstream fout( outFileName, ios::out | ios::binary );
if (!fout){
cout << "Cannot open c_water_hash_array.bin!" << endl;
return 1;
}
for( i=0; i<=SIZE; i+=1 ){
hash = waterhash((void *) key_array, i, WATER_SEED);
fout.write((char *) &hash, 4);
}
fout.close();
return 0;
}
int write_pengy(){
size_t i;
uint64_t hash;
string outFileName = "c_pengy_hash_array.bin";
std::ofstream fout( outFileName, ios::out | ios::binary );
if (!fout){
cout << "Cannot open c_pengy_hash_array.bin!" << endl;
return 1;
}
for( i=0; i<=SIZE; i+=1 ){
hash = pengyhash((void *) key_array, i, PENGY_SEED);
fout.write((char *) &hash, 8);
}
fout.close();
return 0;
}
int write_spooky(){
size_t i;
uint64_t hash[2];
string outFileName = "c_spooky_hash_array.bin";
std::ofstream fout( outFileName, ios::out | ios::binary );
if (!fout){
cout << "Cannot open c_spooky_hash_array.bin!" << endl;
return 1;
}
for( i=0; i<=SIZE; i+=1 ){
SpookyHash128_with_state_test((void *) key_array, i, (void *) SPOOKY_SEED, (void *) hash);
fout.write((char *) hash, 16);
}
fout.close();
return 0;
}
int generate_all_c_hash(){
if (read_keys()==1){return 1;};
if (write_nmhash32()==1){return 1;};
if (write_nmhash32x()==1){return 1;};
if (write_water()==1){return 1;};
if (write_pengy()==1){return 1;};
if (write_spooky()==1){return 1;};
return 0;
}
/*
int main(){
if (read_keys()==1){return 1;};
if (write_nmhash32()==1){return 1;};
if (write_nmhash32x()==1){return 1;};
if (write_water()==1){return 1;};
if (write_pengy()==1){return 1;};
if (write_spooky()==1){return 1;};
return 0;
}
*/
fortran-lang-stdlib-0ede301/test/string/ 0000775 0001750 0001750 00000000000 15135654166 020453 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/string/test_string_to_number.fypp 0000664 0001750 0001750 00000012004 15135654166 025767 0 ustar alastair alastair #: include "common.fypp"
module test_string_to_number
use stdlib_kinds, only: sp, dp, xdp, qp
use stdlib_str2num, only: to_num
use testdrive, only : new_unittest, unittest_type, error_type, check
implicit none
contains
!> Collect all exported unit tests
subroutine collect_string_to_number(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("to_sp", test_to_sp), &
new_unittest("to_dp", test_to_dp) &
#:if WITH_QP
, new_unittest("to_qp", test_to_qp) &
#:endif
#:if WITH_XDP
, new_unittest("to_xdp", test_to_xdp) &
#:endif
]
end subroutine collect_string_to_number
#:for k1, t1 in REAL_KINDS_TYPES
subroutine test_to_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
integer, parameter :: wp = ${k1}$
call check(error, ucheck("1.234"))
if (allocated(error)) return
call check(error, ucheck("1.E1"))
if (allocated(error)) return
call check(error, ucheck("1e0"))
if (allocated(error)) return
call check(error, ucheck("0.1234E0"))
if (allocated(error)) return
call check(error, ucheck("12.34E0"))
if (allocated(error)) return
call check(error, ucheck("0.34E2"))
if (allocated(error)) return
call check(error, ucheck(".34e0"))
if (allocated(error)) return
call check(error, ucheck("34.E1"))
if (allocated(error)) return
call check(error, ucheck("-34.5E1"))
if (allocated(error)) return
call check(error, ucheck("0.0021E10"))
if (allocated(error)) return
call check(error, ucheck("12.21e-1"))
if (allocated(error)) return
call check(error, ucheck("12.21e+001 "))
if (allocated(error)) return
call check(error, ucheck("-1"))
if (allocated(error)) return
call check(error, ucheck(" -0.23317260678539647E-01 "))
if (allocated(error)) return
call check(error, ucheck(" 2.5647869e-003 "//char(13)//char(10)))
if (allocated(error)) return
call check(error, ucheck("1.-3"))
if (allocated(error)) return
call check(error, ucheck("Inf"))
if (allocated(error)) return
call check(error, ucheck("-Inf"))
if (allocated(error)) return
call check(error, ucheck("NaN"))
if (allocated(error)) return
call check(error, ucheck("0.123456789123456789123456789123456789"))
if (allocated(error)) return
call check(error, ucheck("1234567890123456789012345678901234567890-9") )
if (allocated(error)) return
call check(error, ucheck("123456.78901234567890123456789012345678901234567890+2") )
if (allocated(error)) return
call check(error, ucheck("0.140129846432481707092372958328991613128026194187651577"//&
& "175706828388979108268586060148663818836212158203125E-44"))
if (allocated(error)) return
contains
logical function ucheck(s)
character(*), intent(in) :: s
real(wp) :: formatted_read_out
real(wp) :: to_num_out
real(wp) :: abs_err
real(wp) :: rel_err
ucheck = .true.
read(s,*) formatted_read_out
to_num_out = to_num(s, to_num_out)
abs_err = to_num_out - formatted_read_out
rel_err = abs_err / formatted_read_out
#:if k1 == "sp"
if(abs(rel_err) > 0.0_wp) then
#:elif k1 == "dp"
if(abs(rel_err) > epsilon(0.0_wp)) then
#:elif k1 == "xdp"
if(abs(rel_err) > 200*epsilon(0.0_wp)) then
#:elif k1 == "qp"
if(abs(rel_err) > 200*epsilon(0.0_wp)) then
#:endif
write(*,"('formatted read : ', g0)") formatted_read_out
write(*,"('to_num : ', g0)") to_num_out
write(*,"('difference abs : ', g0)") abs_err
write(*,"('difference rel : ', g0, '%')") rel_err * 100
ucheck = .false.
end if
end function
end subroutine
#:endfor
end module test_string_to_number
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_string_to_number, only : collect_string_to_number
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("string_to_number", collect_string_to_number) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/string/test_string_derivedtype_io.f90 0000664 0001750 0001750 00000007300 15135654166 026433 0 ustar alastair alastair ! SPDX-Identifer: MIT
module test_string_derivedtype_io
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_string_type, only : string_type, assignment(=), len, &
write(formatted), read(formatted), write(unformatted), read(unformatted), &
operator(==)
implicit none
contains
!> Collect all exported unit tests
subroutine collect_string_derivedtype_io(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("listdirected_io", test_listdirected_io), &
new_unittest("formatted_io", test_formatted_io), &
new_unittest("unformatted_io", test_unformatted_io) &
]
end subroutine collect_string_derivedtype_io
subroutine test_listdirected_io(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: io, stat
string = "Important saved value"
open(newunit=io, form="formatted", status="scratch")
write(io, *) string
write(io, *) ! Pad with a newline or we might run into EOF while reading
string = ""
rewind(io)
read(io, *, iostat=stat) string
close(io)
call check(error, stat == 0)
if (allocated(error)) return
call check(error, len(string) == 21)
if (allocated(error)) return
call check(error, string == "Important saved value")
end subroutine test_listdirected_io
subroutine test_formatted_io(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: io, stat
string = "Important saved value"
open(newunit=io, form="formatted", status="scratch")
write(io, '(dt)') string
write(io, '(a)') ! Pad with a newline or we might run into EOF while reading
string = ""
rewind(io)
read(io, *, iostat=stat) string
close(io)
call check(error, stat == 0)
if (allocated(error)) return
call check(error, len(string) == 21)
if (allocated(error)) return
call check(error, string == "Important saved value")
end subroutine test_formatted_io
subroutine test_unformatted_io(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: io
string = "Important saved value"
open(newunit=io, form="unformatted", status="scratch")
write(io) string
string = ""
rewind(io)
read(io) string
close(io)
call check(error, len(string) == 21)
if (allocated(error)) return
call check(error, string == "Important saved value")
end subroutine test_unformatted_io
end module test_string_derivedtype_io
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_string_derivedtype_io, only : collect_string_derivedtype_io
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("string-derivedtype-io", collect_string_derivedtype_io) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/string/test_string_assignment.fypp 0000664 0001750 0001750 00000007506 15135654166 026160 0 ustar alastair alastair #:include "common.fypp"
! SPDX-Identifier: MIT
module test_string_assignment
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_kinds, only : int8, int16, int32, int64, lk, c_bool
use stdlib_string_type, only : string_type, assignment(=), operator(==), len
implicit none
contains
!> Collect all exported unit tests
subroutine collect_string_assignment(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("assignment", test_assignment), &
new_unittest("constructor", test_constructor) &
]
end subroutine collect_string_assignment
subroutine test_assignment(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
call check(error, len(string) == 0)
if (allocated(error)) return
string = "Sequence"
call check(error, len(string) == 8)
end subroutine test_assignment
subroutine test_constructor(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=128) :: flc
write(flc, '(g0)') -1026191
call check(error, string_type(-1026191) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') 124787
call check(error, string_type(124787) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') -2_int8
call check(error, string_type(-2_int8) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') 5_int8
call check(error, string_type(5_int8) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') -72_int16
call check(error, string_type(-72_int16) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') -8924889_int32
call check(error, string_type(-8924889_int32) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') 2378405_int32
call check(error, string_type(2378405_int32) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') 921092378411_int64
call check(error, string_type(921092378411_int64) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') -1272835761_int64
call check(error, string_type(-1272835761_int64) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') .true.
call check(error, string_type(.true.) == trim(flc))
if (allocated(error)) return
write(flc, '(g0)') .false.
call check(error, string_type(.false.) == trim(flc))
if (allocated(error)) return
#:if WITH_CBOOL
write(flc, '(g0)') .false._c_bool
call check(error, string_type(.false._c_bool) == trim(flc))
if (allocated(error)) return
#:endif
write(flc, '(g0)') .true._lk
call check(error, string_type(.true._lk) == trim(flc))
end subroutine test_constructor
end module test_string_assignment
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_string_assignment, only : collect_string_assignment
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("string-assignment", collect_string_assignment) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/string/test_string_functions.f90 0000664 0001750 0001750 00000102734 15135654166 025437 0 ustar alastair alastair ! SPDX-Identifier: MIT
module test_string_functions
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_string_type, only : string_type, assignment(=), operator(==), &
to_lower, to_upper, to_title, to_sentence, reverse
use stdlib_strings, only: slice, find, replace_all, padl, padr, count, zfill
use stdlib_optval, only: optval
use stdlib_strings, only : to_string
implicit none
contains
!> Collect all exported unit tests
subroutine collect_string_functions(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("to_lower_string", test_to_lower_string), &
new_unittest("to_upper_string", test_to_upper_string), &
new_unittest("to_title_string", test_to_title_string), &
new_unittest("to_sentence_string", test_to_sentence_string), &
new_unittest("reverse_string", test_reverse_string), &
new_unittest("slice_string", test_slice_string), &
new_unittest("slice_gen", test_slice_gen), &
new_unittest("find", test_find), &
new_unittest("replace_all", test_replace_all), &
new_unittest("padl", test_padl), &
new_unittest("padr", test_padr), &
new_unittest("count", test_count), &
new_unittest("zfill", test_zfill) &
]
end subroutine collect_string_functions
subroutine test_to_lower_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string, compare_string
test_string = "To_LoWEr !$%-az09AZ"
compare_string = "to_lower !$%-az09az"
call check(error, to_lower(test_string) == compare_string)
end subroutine test_to_lower_string
subroutine test_to_upper_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string, compare_string
test_string = "To_UpPeR !$%-az09AZ"
compare_string = "TO_UPPER !$%-AZ09AZ"
call check(error, to_upper(test_string) == compare_string)
end subroutine test_to_upper_string
subroutine test_to_title_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string, compare_string
test_string = "tO_%t!TL3 7h1S p#ra$e"
compare_string = "To_%T!Tl3 7h1s P#Ra$E"
call check(error, to_title(test_string) == compare_string)
end subroutine test_to_title_string
subroutine test_to_sentence_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string, compare_string
test_string = "_#To seNtEncE !$%-az09AZ"
compare_string = "_#To sentence !$%-az09az"
call check(error, to_sentence(test_string) == compare_string)
end subroutine test_to_sentence_string
subroutine test_reverse_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string, compare_string
test_string = "_To ReVerSe !$%-az09AZ "
compare_string = " ZA90za-%$! eSreVeR oT_"
call check(error, reverse(test_string) == compare_string)
end subroutine test_reverse_string
subroutine test_slice_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string
test_string = "abcdefghijklmnopqrstuvwxyz"
! Only one argument is given
! Valid
call check(error, slice(test_string, first=10) == "jklmnopqrstuvwxyz", &
"slice, Valid arguments: first=10") ! last=+inf
if (allocated(error)) return
call check(error, slice(test_string, last=10) == "abcdefghij", &
"slice, Valid arguments: last=10") ! first=-inf
if (allocated(error)) return
call check(error, slice(test_string, stride=3) == "adgjmpsvy", &
"slice, Valid arguments: stride=3") ! first=-inf, last=+inf
if (allocated(error)) return
call check(error, slice(test_string, stride=-3) == "zwtqnkheb", &
"slice, Valid arguments: stride=-3") ! first=+inf, last=-inf
if (allocated(error)) return
! Invalid
call check(error, slice(test_string, first=27) == "", &
"slice, Invalid arguments: first=27") ! last=+inf
if (allocated(error)) return
call check(error, slice(test_string, first=-10) == "abcdefghijklmnopqrstuvwxyz", &
"slice, Invalid arguments: first=-10") ! last=+inf
if (allocated(error)) return
call check(error, slice(test_string, last=-2) == "", &
"slice, Invalid arguments: last=-2") ! first=-inf
if (allocated(error)) return
call check(error, slice(test_string, last=30) == "abcdefghijklmnopqrstuvwxyz", &
"slice, Invalid arguments: last=30") ! first=-inf
if (allocated(error)) return
call check(error, slice(test_string, stride=0) == "abcdefghijklmnopqrstuvwxyz", &
"slice, Invalid arguments: stride=0") ! stride=1
if (allocated(error)) return
! Only two arguments are given
! Valid
call check(error, slice(test_string, first=10, last=20) == "jklmnopqrst", &
"slice, Valid arguments: first=10, last=20")
if (allocated(error)) return
call check(error, slice(test_string, first=7, last=2) == "gfedcb", &
"slice, Valid arguments: first=7, last=2") ! stride=-1
if (allocated(error)) return
call check(error, slice(test_string, first=10, stride=-2) == "jhfdb", &
"slice, Valid arguments: first=10, stride=-2") ! last=-inf
if (allocated(error)) return
call check(error, slice(test_string, last=21, stride=-2) == "zxv", &
"slice, Valid arguments: last=21, stride=-2") ! first=+inf
if (allocated(error)) return
! Atleast one argument is invalid
call check(error, slice(test_string, first=30, last=-3) == "zyxwvutsrqponmlkjihgfedcba", &
"slice, Invalid arguments: first=30, last=-3")
if (allocated(error)) return
call check(error, slice(test_string, first=1, last=-20) == "a", &
"slice, Invalid arguments: first=1, last=-20")
if (allocated(error)) return
call check(error, slice(test_string, first=7, last=-10) == "gfedcba", &
"slice, Invalid arguments: first=7, last=-10")
if (allocated(error)) return
call check(error, slice(test_string, first=500, last=22) == "zyxwv", &
"slice, Invalid arguments: first=500, last=22")
if (allocated(error)) return
call check(error, slice(test_string, first=50, last=27) == "", &
"slice, Invalid arguments: first=50, last=27")
if (allocated(error)) return
call check(error, slice(test_string, first=-20, last=0) == "", &
"slice, Invalid arguments: first=-20, last=0")
if (allocated(error)) return
call check(error, slice(test_string, last=-3, stride=-2) == "zxvtrpnljhfdb", &
"slice, Invalid arguments: last=-3, stride=-2") ! first=+inf
if (allocated(error)) return
call check(error, slice(test_string, last=10, stride=0) == "abcdefghij", &
"slice, Invalid arguments: last=10, stride=0") ! stride=1
if (allocated(error)) return
call check(error, slice(test_string, first=-2, stride=-2) == "", &
"slice, Invalid arguments: first=-2, stride=-2") ! last=-inf
if (allocated(error)) return
call check(error, slice(test_string, first=27, stride=2) == "", &
"slice, Invalid arguments: first=27, stride=2") ! last=+inf
if (allocated(error)) return
call check(error, slice(test_string, last=27, stride=-1) == "", &
"slice, Invalid arguments: last=27, stride=-1") ! first=+inf
if (allocated(error)) return
! All three arguments are given
! Valid
call check(error, slice(test_string, first=2, last=16, stride=3) == "behkn", &
"slice, Valid arguments: first=2, last=16, stride=3")
if (allocated(error)) return
call check(error, slice(test_string, first=16, last=2, stride=-3) == "pmjgd", &
"slice, Valid arguments: first=16, last=2, stride=-3")
if (allocated(error)) return
call check(error, slice(test_string, first=7, last=7, stride=-4) == "g", &
"slice, Valid arguments: first=7, last=7, stride=-4")
if (allocated(error)) return
call check(error, slice(test_string, first=7, last=7, stride=3) == "g", &
"slice, Valid arguments: first=7, last=7, stride=3")
if (allocated(error)) return
call check(error, slice(test_string, first=2, last=6, stride=-1) == "", &
"slice, Valid arguments: first=2, last=6, stride=-1")
if (allocated(error)) return
call check(error, slice(test_string, first=20, last=10, stride=2) == "", &
"slice, Valid arguments: first=20, last=10, stride=2")
if (allocated(error)) return
! Atleast one argument is invalid
call check(error, slice(test_string, first=20, last=30, stride=2) == "tvxz", &
"slice, Invalid arguments: first=20, last=30, stride=2")
if (allocated(error)) return
call check(error, slice(test_string, first=-20, last=30, stride=2) == "acegikmoqsuwy", &
"slice, Invalid arguments: first=-20, last=30, stride=2")
if (allocated(error)) return
call check(error, slice(test_string, first=26, last=30, stride=1) == "z", &
"slice, Invalid arguments: first=26, last=30, stride=1")
if (allocated(error)) return
call check(error, slice(test_string, first=1, last=-20, stride=-1) == "a", &
"slice, Invalid arguments: first=1, last=-20, stride=-1")
if (allocated(error)) return
call check(error, slice(test_string, first=26, last=20, stride=1) == "", &
"slice, Invalid arguments: first=26, last=20, stride=1")
if (allocated(error)) return
call check(error, slice(test_string, first=1, last=20, stride=-1) == "", &
"slice, Invalid arguments: first=1, last=20, stride=-1")
if (allocated(error)) return
test_string = ""
! Empty string input
call check(error, slice(test_string, first=-2, last=6) == "", &
"slice, Empty string: first=-2, last=6")
if (allocated(error)) return
call check(error, slice(test_string, first=6, last=-2) == "", &
"slice, Empty string: first=6, last=-2")
if (allocated(error)) return
call check(error, slice(test_string, first=-10) == "", &
"slice, Empty string: first=-10") ! last=+inf
if (allocated(error)) return
call check(error, slice(test_string, last=10) == "", &
"slice, Empty string: last=10") ! first=-inf
if (allocated(error)) return
call check(error, slice(test_string) == "", &
"slice, Empty string: no arguments provided")
end subroutine test_slice_string
subroutine test_find(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string_1, test_string_2, test_pattern_1, test_pattern_2
test_string_1 = "qwqwqwqwqwqwqw"
test_string_2 = "abccbabccbabc"
test_pattern_1 = "qwq"
test_pattern_2 = "abccbabc"
call check(error, all(find([test_string_1, test_string_2], test_pattern_1, 4) == [7, 0]), &
& 'find: [test_string_1, test_string_2], test_pattern_1, 4')
if (allocated(error)) return
call check(error, all(find(test_string_1, [test_pattern_1, test_pattern_2], 3, .false.) == [9, 0]), &
& 'find: test_string_1, [test_pattern_1, test_pattern_2], 3, .false.')
if (allocated(error)) return
call check(error, find(test_string_1, test_pattern_1, 7) == 0, &
& 'find: test_string_1, test_pattern_1, 7')
if (allocated(error)) return
call check(error, all(find([test_string_1, test_string_2, test_string_2], [test_pattern_1, &
& test_pattern_2, test_pattern_2], [7, 2, 2], [.true., .false., .true.]) == [0, 0, 6]), &
& 'find: [test_string_1, test_string_2, test_string_2], [test_pattern_1, &
& test_pattern_2, test_pattern_2], [7, 2, 2], [.true., .false., .true.]')
if (allocated(error)) return
call check(error, find("qwqwqwqwqwqwqw", test_pattern_1) == 1, &
& 'find: "qwqwqwqwqwqwqw", test_pattern_1')
if (allocated(error)) return
call check(error, all(find(test_string_1, ["qwq", "wqw"], 2) == [3, 4]), &
& 'find: test_string_1, ["qwq", "wqw"], 2')
if (allocated(error)) return
call check(error, find("qwqwqwqwqwqwqw", "qwq", 2, .false.) == 5, &
& 'find: "qwqwqwqwqwqwqw", "qwq", 2, .false.')
if (allocated(error)) return
call check(error, find("", "") == 0, &
& 'find: "", ""')
if (allocated(error)) return
call check(error, find("", test_pattern_1) == 0, &
& 'find: "", test_pattern_1')
if (allocated(error)) return
call check(error, find(test_string_1, "") == 0, &
& 'find: test_string_1, ""')
end subroutine test_find
subroutine test_slice_gen(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), parameter :: test = &
& "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
integer :: i, j, k
integer, parameter :: offset = 3
do i = 1 - offset, len(test) + offset
call check_slicer(error, test, first=i)
if (allocated(error)) return
end do
do i = 1 - offset, len(test) + offset
call check_slicer(error, test, last=i)
if (allocated(error)) return
end do
do i = -len(test) - offset, len(test) + offset
call check_slicer(error, test, stride=i)
if (allocated(error)) return
end do
do i = 1 - offset, len(test) + offset
do j = 1 - offset, len(test) + offset
call check_slicer(error, test, first=i, last=j)
if (allocated(error)) return
end do
end do
do i = 1 - offset, len(test) + offset
do j = -len(test) - offset, len(test) + offset
call check_slicer(error, test, first=i, stride=j)
if (allocated(error)) return
end do
end do
do i = 1 - offset, len(test) + offset
do j = -len(test) - offset, len(test) + offset
call check_slicer(error, test, last=i, stride=j)
if (allocated(error)) return
end do
end do
do i = 1 - offset, len(test) + offset
do j = 1 - offset, len(test) + offset
do k = -len(test) - offset, len(test) + offset
call check_slicer(error, test, first=i, last=j, stride=k)
if (allocated(error)) return
end do
end do
end do
end subroutine test_slice_gen
subroutine check_slicer(error, string, first, last, stride)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: string
integer, intent(in), optional :: first
integer, intent(in), optional :: last
integer, intent(in), optional :: stride
character(len=:), allocatable :: actual, expected, message
logical :: stat
actual = slice(string, first, last, stride)
expected = reference_slice(string, first, last, stride)
stat = actual == expected
if (.not.stat) then
message = "For input '"//string//"'"//new_line('a')
if (present(first)) then
message = message // "first: "//to_string(first)//new_line('a')
end if
if (present(last)) then
message = message // "last: "//to_string(last)//new_line('a')
end if
if (present(stride)) then
message = message // "stride: "//to_string(stride)//new_line('a')
end if
message = message // "Expected: '"//expected//"' but got '"//actual//"'"
end if
call check(error, stat, message)
end subroutine check_slicer
pure function reference_slice(string, first, last, stride) result(sliced_string)
character(len=*), intent(in) :: string
integer, intent(in), optional :: first
integer, intent(in), optional :: last
integer, intent(in), optional :: stride
character(len=:), allocatable :: sliced_string
character(len=1), allocatable :: carray(:)
integer :: first_, last_, stride_
stride_ = 1
if (present(stride)) then
stride_ = merge(stride_, stride, stride == 0)
else
if (present(first) .and. present(last)) then
if (last < first) stride_ = -1
end if
end if
if (stride_ < 0) then
last_ = min(max(optval(last, 1), 1), len(string)+1)
first_ = min(max(optval(first, len(string)), 0), len(string))
else
first_ = min(max(optval(first, 1), 1), len(string)+1)
last_ = min(max(optval(last, len(string)), 0), len(string))
end if
carray = string_to_carray(string)
carray = carray(first_:last_:stride_)
sliced_string = carray_to_string(carray)
end function reference_slice
pure function string_to_carray(string) result(carray)
character(len=*), intent(in) :: string
character(len=1) :: carray(len(string))
carray = transfer(string, carray)
end function string_to_carray
pure function carray_to_string(carray) result(string)
character(len=1), intent(in) :: carray(:)
character(len=size(carray)) :: string
string = transfer(carray, string)
end function carray_to_string
subroutine test_replace_all(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string_1, test_pattern_1, test_replacement_1
type(string_type) :: test_string_2, test_pattern_2, test_replacement_2
test_string_1 = "mutate DNA sequence: GTTATCGTATGCCGTAATTAT"
test_pattern_1 = "TAT"
test_replacement_1 = "ATA"
test_string_2 = "mutate DNA sequence: AGAGAGCCTAGAGAGAG"
test_pattern_2 = "AGA"
test_replacement_2 = "aga"
! all 3 as string_type
call check(error, replace_all(test_string_1, test_pattern_1, test_replacement_1) == &
& "mutate DNA sequence: GTATACGATAGCCGTAATATA", &
& "replace_all: all 3 string_type, test case 1")
if (allocated(error)) return
call check(error, replace_all(test_string_2, test_pattern_2, test_replacement_2) == &
& "mutate DNA sequence: agaGAGCCTagaGagaG", &
& "replace_all: all 3 string_type, test case 2")
if (allocated(error)) return
call check(error, replace_all(test_string_2, test_pattern_2, test_replacement_1) == &
& "mutate DNA sequence: ATAGAGCCTATAGATAG", &
& "replace_all: all 3 string_type, test case 3")
if (allocated(error)) return
! 2 as string_type and 1 as character scalar
call check(error, replace_all(test_string_1, "tat", test_replacement_1) == &
& "muATAe DNA sequence: GTTATCGTATGCCGTAATTAT", &
& "replace_all: 2 string_type & 1 character scalar, test case 1")
if (allocated(error)) return
call check(error, replace_all(test_string_2, test_pattern_2, "GC") == &
& "mutate DNA sequence: GCGAGCCTGCGGCG", &
& "replace_all: 2 string_type & 1 character scalar, test case 2")
if (allocated(error)) return
call check(error, replace_all("mutate DNA sequence: AGAGAGCCTAGAGAGAG", test_pattern_2, &
& test_replacement_2) == "mutate DNA sequence: agaGAGCCTagaGagaG", &
& "replace_all: 2 string_type & 1 character scalar, test case 3")
if (allocated(error)) return
! 1 as string_type and 2 as character scalar
call check(error, replace_all(test_string_1, "TAT", "ATA") == &
& "mutate DNA sequence: GTATACGATAGCCGTAATATA", &
& "replace_all: 1 string_type & 2 character scalar, test case 1")
if (allocated(error)) return
call check(error, replace_all("mutate DNA sequence: AGAGAGCCTAGAGAGAG", test_pattern_2, "GC") == &
& "mutate DNA sequence: GCGAGCCTGCGGCG", &
& "replace_all: 1 string_type & 2 character scalar, test case 2")
if (allocated(error)) return
call check(error, replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", "TA", &
& test_replacement_2) == "mutate DNA sequence: GTagaTCGagaTGCCGagaATagaT", &
& "replace_all: 1 string_type & 2 character scalar, test case 3")
if (allocated(error)) return
call check(error, replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", &
& test_pattern_1, "") == "mutate DNA sequence: GTCGGCCGTAAT", &
& "replace_all: 1 string_type & 2 character scalar, test case 4")
if (allocated(error)) return
call check(error, replace_all(test_string_1, "", "anything here") == test_string_1, &
& "replace_all: 1 string_type & 2 character scalar, test case 5")
if (allocated(error)) return
call check(error, replace_all("", test_pattern_2, "anything here") == "", &
& "replace_all: 1 string_type & 2 character scalar, test case 6")
if (allocated(error)) return
! all 3 as character scalar
call check(error, replace_all("mutate DNA sequence: GTTATCGTATGCCGTAATTAT", &
& "GT", "gct") == "mutate DNA sequence: gctTATCgctATGCCgctAATTAT", &
& "replace_all: all 3 character scalar, test case 1")
if (allocated(error)) return
call check(error, replace_all("", "anything here", "anything here") == "", &
& "replace_all: all 3 character scalar, test case 2")
end subroutine test_replace_all
subroutine test_padl(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string
character(len=:), allocatable :: test_char
test_string = "left pad this string"
test_char = " left pad this string "
! output_length > len(string)
call check(error, padl(test_string, 25, "#") == "#####left pad this string", &
& 'padl: output_length > len(string), test_case 1')
if (allocated(error)) return
call check(error, padl(test_string, 22, "$") == "$$left pad this string", &
& 'padl: output_length > len(string), test_case 2')
if (allocated(error)) return
call check(error, padl(test_string, 23) == " left pad this string", &
& 'padl: output_length > len(string), test_case 3')
if (allocated(error)) return
call check(error, padl(test_char, 26) == " left pad this string ", &
& 'padl: output_length > len(string), test_case 4')
if (allocated(error)) return
call check(error, padl(test_char, 26, "&") == "&& left pad this string ", &
& 'padl: output_length > len(string), test_case 5')
if (allocated(error)) return
call check(error, padl("", 10, "!") == "!!!!!!!!!!", &
& 'padl: output_length > len(string), test_case 6')
if (allocated(error)) return
! output_length <= len(string)
call check(error, padl(test_string, 18, "#") == "left pad this string", &
& 'padl: output_length <= len(string), test_case 1')
if (allocated(error)) return
call check(error, padl(test_string, -4, "@") == "left pad this string", &
& 'padl: output_length <= len(string), test_case 2')
if (allocated(error)) return
call check(error, padl(test_char, 20, "0") == " left pad this string ", &
& 'padl: output_length <= len(string), test_case 3')
if (allocated(error)) return
call check(error, padl(test_char, 17) == " left pad this string ", &
& 'padl: output_length <= len(string), test_case 4')
if (allocated(error)) return
call check(error, padl("", 0, "!") == "", &
& 'padl: output_length <= len(string), test_case 5')
if (allocated(error)) return
call check(error, padl("", -12, "!") == "", &
& 'padl: output_length <= len(string), test_case 6')
end subroutine test_padl
subroutine test_padr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string
character(len=:), allocatable :: test_char
test_string = "right pad this string"
test_char = " right pad this string "
! output_length > len(string)
call check(error, padr(test_string, 25, "#") == "right pad this string####", &
& 'padr: output_length > len(string), test_case 1')
if (allocated(error)) return
call check(error, padr(test_string, 22, "$") == "right pad this string$", &
& 'padr: output_length > len(string), test_case 2')
if (allocated(error)) return
call check(error, padr(test_string, 24) == "right pad this string ", &
& 'padr: output_length > len(string), test_case 3')
if (allocated(error)) return
call check(error, padr(test_char, 27) == " right pad this string ", &
& 'padr: output_length > len(string), test_case 4')
if (allocated(error)) return
call check(error, padr(test_char, 27, "&") == " right pad this string &&", &
& 'padr: output_length > len(string), test_case 5')
if (allocated(error)) return
call check(error, padr("", 10, "!") == "!!!!!!!!!!", &
& 'padr: output_length > len(string), test_case 6')
if (allocated(error)) return
! output_length <= len(string)
call check(error, padr(test_string, 18, "#") == "right pad this string", &
& 'padr: output_length <= len(string), test_case 1')
if (allocated(error)) return
call check(error, padr(test_string, -4, "@") == "right pad this string", &
& 'padr: output_length <= len(string), test_case 2')
if (allocated(error)) return
call check(error, padr(test_char, 20, "0") == " right pad this string ", &
& 'padr: output_length <= len(string), test_case 3')
if (allocated(error)) return
call check(error, padr(test_char, 17) == " right pad this string ", &
& 'padr: output_length <= len(string), test_case 4')
if (allocated(error)) return
call check(error, padr("", 0, "!") == "", &
& 'padr: output_length <= len(string), test_case 5')
if (allocated(error)) return
call check(error, padr("", -12, "!") == "", &
& 'padr: output_length <= len(string), test_case 6')
end subroutine test_padr
subroutine test_count(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string_1, test_string_2, test_pattern_1, test_pattern_2
test_string_1 = "DNA sequence: AGAGAGAGTCCTGTCGAGA"
test_string_2 = "DNA sequence: GTCCTGTCCTGTCAGA"
test_pattern_1 = "AGA"
test_pattern_2 = "GTCCTGTC"
! all 2 as string_type
call check(error, all(count([test_string_1, test_string_2], test_pattern_1) == [4, 1]), &
& 'count: all 2 as string_type, test case 1')
if (allocated(error)) return
call check(error, all(count(test_string_1, [test_pattern_1, test_pattern_2], .false.) == [3, 1]), &
& 'count: all 2 as string_type, test case 2')
if (allocated(error)) return
call check(error, count(test_string_2, test_pattern_1, .false.) == 1, &
& 'count: all 2 as string_type, test case 3')
if (allocated(error)) return
call check(error, all(count([test_string_2, test_string_2, test_string_1], &
& [test_pattern_2, test_pattern_2, test_pattern_1], [.true., .false., .false.]) == &
& [2, 1, 3]), 'count: all 2 as string_type, test case 4')
if (allocated(error)) return
call check(error, all(count([[test_string_1, test_string_2], [test_string_1, test_string_2]], &
& [[test_pattern_1, test_pattern_2], [test_pattern_2, test_pattern_1]], .true.) == &
& [[4, 2], [1, 1]]), 'count: all 2 as string_type, test case 5')
if (allocated(error)) return
! 1 string_type and 1 character scalar
call check(error, all(count(test_string_1, ["AGA", "GTC"], [.true., .false.]) == [4, 2]), &
& 'count: 1 string_type and 1 character scalar, test case 1')
if (allocated(error)) return
call check(error, all(count([test_string_1, test_string_2], ["CTC", "GTC"], [.true., .false.]) == &
& [0, 3]), 'count: 1 string_type and 1 character scalar, test case 2')
if (allocated(error)) return
call check(error, all(count(["AGAGAGAGTCCTGTCGAGA", "AGAGAGAGTCCTGTCGAGA"], &
& test_pattern_1, [.false., .true.]) == [3, 4]), &
& 'count: 1 string_type and 1 character scalar, test case 3')
if (allocated(error)) return
call check(error, count(test_string_1, "GAG") == 4, &
& 'count: 1 string_type and 1 character scalar, test case 4')
if (allocated(error)) return
call check(error, count("DNA sequence: GTCCTGTCCTGTCAGA", test_pattern_2, .false.) == 1, &
& 'count: 1 string_type and 1 character scalar, test case 5')
if (allocated(error)) return
! all 2 character scalar
call check(error, all(count("", ["mango", "trees"], .true.) == [0, 0]), &
& 'count: all 2 character scalar, test case 1')
if (allocated(error)) return
call check(error, count("", "", .true.) == 0, 'count: all 2 character scalar, test case 2')
if (allocated(error)) return
call check(error, all(count(["mango", "trees"], "", .true.) == [0, 0]), &
& 'count: all 2 character scalar, test case 3')
end subroutine test_count
subroutine test_zfill(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: test_string
character(len=:), allocatable :: test_char
test_string = "left pad this string"
test_char = " left pad this string "
! output_length > len(string)
call check(error, zfill(test_string, 25) == "00000left pad this string", &
& 'zfill: output_length > len(string), test_case 1')
if (allocated(error)) return
call check(error, zfill(test_string, 22) == "00left pad this string", &
& 'zfill: output_length > len(string), test_case 2')
if (allocated(error)) return
call check(error, zfill(test_string, 23) == "000left pad this string", &
& 'zfill: output_length > len(string), test_case 3')
if (allocated(error)) return
call check(error, zfill(test_char, 26) == "00 left pad this string ", &
& 'zfill: output_length > len(string), test_case 4')
if (allocated(error)) return
call check(error, zfill("", 10) == "0000000000", &
& 'zfill: output_length > len(string), test_case 5')
if (allocated(error)) return
! output_length <= len(string)
call check(error, zfill(test_string, 18) == "left pad this string", &
& 'zfill: output_length <= len(string), test_case 1')
if (allocated(error)) return
call check(error, zfill(test_string, -4) == "left pad this string", &
& 'zfill: output_length <= len(string), test_case 2')
if (allocated(error)) return
call check(error, zfill(test_char, 20) == " left pad this string ", &
& 'zfill: output_length <= len(string), test_case 3')
if (allocated(error)) return
call check(error, zfill(test_char, 17) == " left pad this string ", &
& 'zfill: output_length <= len(string), test_case 4')
if (allocated(error)) return
call check(error, zfill("", 0) == "", &
& 'zfill: output_length <= len(string), test_case 5')
if (allocated(error)) return
call check(error, zfill("", -12) == "", &
& 'zfill: output_length <= len(string), test_case 6')
end subroutine test_zfill
end module test_string_functions
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_string_functions, only : collect_string_functions
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("string-functions", collect_string_functions) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/string/CMakeLists.txt 0000664 0001750 0001750 00000000706 15135654166 023216 0 ustar alastair alastair #### Pre-process: .fpp -> .f90 via Fypp
# Create a list of the files to be preprocessed
set(fppFiles
test_string_assignment.fypp
test_string_to_number.fypp
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(string_assignment)
ADDTEST(string_operator)
ADDTEST(string_intrinsic)
ADDTEST(string_match)
ADDTEST(string_derivedtype_io)
ADDTEST(string_functions)
ADDTEST(string_strip_chomp)
ADDTEST(string_to_number)
ADDTEST(string_to_string)
fortran-lang-stdlib-0ede301/test/string/test_string_strip_chomp.f90 0000664 0001750 0001750 00000022646 15135654166 025761 0 ustar alastair alastair ! SPDX-Identifier: MIT
module test_strip_chomp
use stdlib_ascii, only : TAB, VT, NUL, LF, CR, FF
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_strings, only : strip, chomp
use stdlib_string_type, only : string_type, operator(==), operator(//)
implicit none
contains
!> Collect all exported unit tests
subroutine collect_strip_chomp(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("strip_char", test_strip_char), &
new_unittest("strip_string", test_strip_string), &
new_unittest("chomp_char", test_chomp_char), &
new_unittest("chomp_string", test_chomp_string), &
new_unittest("chomp_set_char", test_chomp_set_char), &
new_unittest("chomp_set_string", test_chomp_set_string), &
new_unittest("chomp_substring_char", test_chomp_substring_char), &
new_unittest("chomp_substring_string", test_chomp_substring_string) &
]
end subroutine collect_strip_chomp
subroutine test_strip_char(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, strip(" hello ") == "hello")
if (allocated(error)) return
call check(error, strip(TAB//"goodbye"//CR//LF) == "goodbye")
if (allocated(error)) return
call check(error, strip(NUL//TAB//LF//VT//FF//CR) == NUL)
if (allocated(error)) return
call check(error, strip(" "//TAB//LF//VT//FF//CR) == "")
if (allocated(error)) return
call check(error, strip(" ! ")//"!" == "!!")
if (allocated(error)) return
call check(error, strip("Hello") == "Hello")
end subroutine test_strip_char
subroutine test_strip_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, strip(string_type(" hello ")) == "hello")
if (allocated(error)) return
call check(error, strip(string_type(TAB//"goodbye"//CR//LF)) == "goodbye")
if (allocated(error)) return
call check(error, strip(string_type(NUL//TAB//LF//VT//FF//CR)) == NUL)
if (allocated(error)) return
call check(error, strip(string_type(" "//TAB//LF//VT//FF//CR)) == "")
if (allocated(error)) return
call check(error, strip(string_type(" ! "))//"!" == "!!")
if (allocated(error)) return
call check(error, strip(string_type("Hello")) == "Hello")
end subroutine test_strip_string
subroutine test_chomp_char(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, chomp("hello") == "hello")
if (allocated(error)) return
call check(error, chomp("hello"//LF) == "hello", "1")
if (allocated(error)) return
call check(error, chomp("hello"//CR//LF) == "hello", "2")
if (allocated(error)) return
call check(error, chomp("hello"//LF//CR) == "hello", "3")
if (allocated(error)) return
call check(error, chomp("hello"//CR) == "hello", "4")
if (allocated(error)) return
call check(error, chomp("hello "//LF//" there") == "hello "//LF//" there")
if (allocated(error)) return
call check(error, chomp("hello"//CR//LF//CR//LF) == "hello")
if (allocated(error)) return
call check(error, chomp("hello"//CR//LF//CR//CR//LF) == "hello")
if (allocated(error)) return
call check(error, chomp(NUL//TAB//LF//VT//FF//CR) == NUL)
if (allocated(error)) return
call check(error, chomp(" "//TAB//LF//VT//FF//CR) == "")
if (allocated(error)) return
call check(error, chomp(" ! ")//"!" == " !!")
end subroutine test_chomp_char
subroutine test_chomp_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, chomp(string_type("hello")) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hello"//LF)) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hello"//CR//LF)) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hello"//LF//CR)) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hello"//CR)) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hello "//LF//" there")) == "hello "//LF//" there")
if (allocated(error)) return
call check(error, chomp(string_type("hello"//CR//LF//CR//LF)) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hello"//CR//LF//CR//CR//LF)) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type(NUL//TAB//LF//VT//FF//CR)) == NUL)
if (allocated(error)) return
call check(error, chomp(string_type(" "//TAB//LF//VT//FF//CR)) == "")
if (allocated(error)) return
call check(error, chomp(string_type(" ! "))//"!" == " !!")
end subroutine test_chomp_string
subroutine test_chomp_set_char(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, chomp("hello", ["l", "o"]) == "he")
if (allocated(error)) return
call check(error, chomp("hello", set=["l", "o"]) == "he")
end subroutine test_chomp_set_char
subroutine test_chomp_set_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, chomp(string_type("hello"), ["l", "o"]) == "he")
if (allocated(error)) return
call check(error, chomp(string_type("hello"), set=["l", "o"]) == "he")
if (allocated(error)) return
call check(error, chomp("hellooooo", ["o", "o"]) == "hell")
if (allocated(error)) return
call check(error, chomp("hellooooo", set=["o", "o"]) == "hell")
end subroutine test_chomp_set_string
subroutine test_chomp_substring_char(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, chomp("hello", "") == "hello")
if (allocated(error)) return
call check(error, chomp("hello", substring="") == "hello")
if (allocated(error)) return
call check(error, chomp("hello", "lo") == "hel")
if (allocated(error)) return
call check(error, chomp("hello", substring="lo") == "hel")
if (allocated(error)) return
call check(error, chomp("hellooooo", "oo") == "hello")
if (allocated(error)) return
call check(error, chomp("hellooooo", substring="oo") == "hello")
if (allocated(error)) return
call check(error, chomp("helhel", substring="hel") == "")
end subroutine test_chomp_substring_char
subroutine test_chomp_substring_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, chomp(string_type("hello"), "") == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hello"), substring="") == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hello"), "lo") == "hel")
if (allocated(error)) return
call check(error, chomp(string_type("hello"), substring="lo") == "hel")
if (allocated(error)) return
call check(error, chomp("hello", string_type("lo")) == "hel")
if (allocated(error)) return
call check(error, chomp("hello", substring=string_type("lo")) == "hel")
if (allocated(error)) return
call check(error, chomp(string_type("hello"), string_type("lo")) == "hel")
if (allocated(error)) return
call check(error, chomp(string_type("hello"), substring=string_type("lo")) == "hel")
if (allocated(error)) return
call check(error, chomp(string_type("hellooooo"), "oo") == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hellooooo"), substring="oo") == "hello")
if (allocated(error)) return
call check(error, chomp("hellooooo", string_type("oo")) == "hello")
if (allocated(error)) return
call check(error, chomp("hellooooo", substring=string_type("oo")) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hellooooo"), string_type("oo")) == "hello")
if (allocated(error)) return
call check(error, chomp(string_type("hellooooo"), substring=string_type("oo")) == "hello")
end subroutine test_chomp_substring_string
end module test_strip_chomp
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_strip_chomp, only : collect_strip_chomp
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("strip-chomp", collect_strip_chomp) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/string/test_string_operator.f90 0000664 0001750 0001750 00000012105 15135654166 025252 0 ustar alastair alastair ! SPDX-Identifer: MIT
module test_string_operator
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_string_type, only : string_type, assignment(=), len, &
operator(>), operator(<), operator(>=), operator(<=), &
operator(/=), operator(==), operator(//)
implicit none
contains
!> Collect all exported unit tests
subroutine collect_string_operator(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("gt", test_gt), &
new_unittest("lt", test_lt), &
new_unittest("ge", test_ge), &
new_unittest("le", test_le), &
new_unittest("eq", test_eq), &
new_unittest("ne", test_ne), &
new_unittest("concat", test_concat) &
]
end subroutine collect_string_operator
subroutine test_gt(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = string > "abc"
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = string > "bcd"
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = string > "cde"
call check(error, res .eqv. .false.)
end subroutine test_gt
subroutine test_lt(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = string < "abc"
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = string < "bcd"
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = string < "cde"
call check(error, res .eqv. .true.)
end subroutine test_lt
subroutine test_ge(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = string >= "abc"
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = string >= "bcd"
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = string >= "cde"
call check(error, res .eqv. .false.)
end subroutine test_ge
subroutine test_le(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = string <= "abc"
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = string <= "bcd"
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = string <= "cde"
call check(error, res .eqv. .true.)
end subroutine test_le
subroutine test_eq(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = string == "abc"
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = string == "bcd"
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = string == "cde"
call check(error, res .eqv. .false.)
end subroutine test_eq
subroutine test_ne(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = string /= "abc"
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = string /= "bcd"
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = string /= "cde"
call check(error, res .eqv. .true.)
end subroutine test_ne
subroutine test_concat(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
string = "Hello, "
string = string // "World!"
call check(error, len(string) == 13)
end subroutine test_concat
end module test_string_operator
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_string_operator, only : collect_string_operator
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("string-operator", collect_string_operator) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/string/test_string_match.f90 0000664 0001750 0001750 00000013154 15135654166 024520 0 ustar alastair alastair ! SPDX-Identifier: MIT
module test_string_match
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_ascii, only : reverse
use stdlib_strings, only : starts_with, ends_with, join
use stdlib_string_type, only : string_type
implicit none
contains
!> Collect all exported unit tests
subroutine collect_string_match(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("starts_with", test_starts_with), &
new_unittest("ends_with", test_ends_with), &
new_unittest("join", test_join) &
]
end subroutine collect_string_match
subroutine check_starts_with(error, string, substring)
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: string
character(len=*), intent(in) :: substring
logical :: match
character(len=:), allocatable :: message
match = index(string, substring) == 1
if (match) then
message = "Failed to recognize that '"//string//"' starts with '"//substring//"'"
else
message = "Incorrectly found that '"//string//"' starts with '"//substring//"'"
end if
call check(error, starts_with(string, substring) .eqv. match, message)
if (allocated(error)) return
call check(error, starts_with(string_type(string), substring) .eqv. match, message)
if (allocated(error)) return
call check(error, starts_with(string, string_type(substring)) .eqv. match, message)
if (allocated(error)) return
call check(error, starts_with(string_type(string), string_type(substring)) .eqv. match, message)
end subroutine check_starts_with
subroutine test_starts_with(error)
type(error_type), allocatable, intent(out) :: error
call check_starts_with(error, "pattern", "pat")
if (allocated(error)) return
call check_starts_with(error, "pat", "pattern")
if (allocated(error)) return
call check_starts_with(error, "pattern", "ern")
if (allocated(error)) return
call check_starts_with(error, "ern", "pattern")
end subroutine test_starts_with
subroutine check_ends_with(error, string, substring)
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: string
character(len=*), intent(in) :: substring
logical :: match
character(len=:), allocatable :: message
match = index(reverse(string), reverse(substring)) == 1
if (match) then
message = "Failed to recognize that '"//string//"' ends with '"//substring//"'"
else
message = "Incorrectly found that '"//string//"' ends with '"//substring//"'"
end if
call check(error, ends_with(string, substring) .eqv. match, message)
if (allocated(error)) return
call check(error, ends_with(string_type(string), substring) .eqv. match, message)
if (allocated(error)) return
call check(error, ends_with(string, string_type(substring)) .eqv. match, message)
if (allocated(error)) return
call check(error, ends_with(string_type(string), string_type(substring)) .eqv. match, message)
end subroutine check_ends_with
subroutine test_join(error)
type(error_type), allocatable, intent(out) :: error
character(len=5) :: test_strings(3)
test_strings = [character(5) :: "one", "two", "three"]
call check_join(error, test_strings, " ", "one two three")
if (allocated(error)) return
call check_join(error, test_strings, ",", "one,two,three")
if (allocated(error)) return
call check_join(error, test_strings, "-", "one-two-three")
end subroutine test_join
subroutine check_join(error, strings, separator, expected)
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: strings(:)
character(len=*), intent(in) :: separator
character(len=*), intent(in) :: expected
character(len=:), allocatable :: joined
character(len=:), allocatable :: message
joined = join(strings, separator)
message = "'join' error: Expected '" // expected // "' but got '" // joined // "'"
call check(error, joined == expected, message)
end subroutine check_join
subroutine test_ends_with(error)
type(error_type), allocatable, intent(out) :: error
call check_ends_with(error, "pattern", "pat")
if (allocated(error)) return
call check_ends_with(error, "pat", "pattern")
if (allocated(error)) return
call check_ends_with(error, "pattern", "ern")
if (allocated(error)) return
call check_ends_with(error, "ern", "pattern")
end subroutine test_ends_with
end module test_string_match
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_string_match, only : collect_string_match
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("string-match", collect_string_match) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/string/test_string_intrinsic.f90 0000664 0001750 0001750 00000070547 15135654166 025437 0 ustar alastair alastair ! SPDX-Identifer: MIT
module test_string_intrinsic
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_string_type
implicit none
abstract interface
!> Actual tester working on a string type and a fixed length character
!> representing the same character sequence
subroutine check1_interface(error, str1, chr1)
import :: string_type, error_type
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1
character(len=*), intent(in) :: chr1
end subroutine check1_interface
!> Actual tester working on two pairs of string type and fixed length
!> character representing the same character sequences
subroutine check2_interface(error, str1, chr1, str2, chr2)
import :: string_type, error_type
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1, str2
character(len=*), intent(in) :: chr1, chr2
end subroutine check2_interface
end interface
contains
!> Collect all exported unit tests
subroutine collect_string_intrinsic(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("lgt", test_lgt), &
new_unittest("llt", test_llt), &
new_unittest("lge", test_lge), &
new_unittest("lle", test_lle), &
new_unittest("trim", test_trim), &
new_unittest("len", test_len), &
new_unittest("len_trim", test_len_trim), &
new_unittest("adjustl", test_adjustl), &
new_unittest("adjustr", test_adjustr), &
new_unittest("scan", test_scan), &
new_unittest("verify", test_verify), &
new_unittest("repeat", test_repeat), &
new_unittest("index", test_index), &
new_unittest("char", test_char), &
new_unittest("ichar", test_ichar), &
new_unittest("iachar", test_iachar), &
new_unittest("move", test_move) &
]
end subroutine collect_string_intrinsic
!> Generate then checker both for the string type created from the character
!> sequence by the contructor and the assignment operation
subroutine check1(error, chr1, checker)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: chr1
procedure(check1_interface) :: checker
call constructor_check1(error, chr1, checker)
if (allocated(error)) return
call assignment_check1(error, chr1, checker)
end subroutine check1
!> Run the actual checker with a string type generated by the custom constructor
subroutine constructor_check1(error, chr1, checker)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: chr1
procedure(check1_interface) :: checker
call checker(error, string_type(chr1), chr1)
end subroutine constructor_check1
!> Run the actual checker with a string type generated by assignment
subroutine assignment_check1(error, chr1, checker)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: chr1
type(string_type) :: str1
procedure(check1_interface) :: checker
str1 = chr1
call checker(error, str1, chr1)
end subroutine assignment_check1
!> Generate then checker both for the string type created from the character
!> sequence by the contructor and the assignment operation as well as the
!> mixed assigment and constructor setup
subroutine check2(error, chr1, chr2, checker)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: chr1, chr2
procedure(check2_interface) :: checker
call constructor_check2(error, chr1, chr2, checker)
if (allocated(error)) return
call assignment_check2(error, chr1, chr2, checker)
if (allocated(error)) return
call mixed_check2(error, chr1, chr2, checker)
end subroutine check2
!> Run the actual checker with both string types generated by the custom constructor
subroutine constructor_check2(error, chr1, chr2, checker)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: chr1, chr2
procedure(check2_interface) :: checker
call checker(error, string_type(chr1), chr1, string_type(chr2), chr2)
end subroutine constructor_check2
!> Run the actual checker with one string type generated by the custom constructor
!> and the other by assignment
subroutine mixed_check2(error, chr1, chr2, checker)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: chr1, chr2
type(string_type) :: str1, str2
procedure(check2_interface) :: checker
str1 = chr1
str2 = chr2
call checker(error, str1, chr1, string_type(chr2), chr2)
if (allocated(error)) return
call checker(error, string_type(chr1), chr1, str2, chr2)
end subroutine mixed_check2
!> Run the actual checker with both string types generated by assignment
subroutine assignment_check2(error, chr1, chr2, checker)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: chr1, chr2
type(string_type) :: str1, str2
procedure(check2_interface) :: checker
str1 = chr1
str2 = chr2
call checker(error, str1, chr1, str2, chr2)
end subroutine assignment_check2
!> Generator for checking the lexical comparison
subroutine gen_lgt(error, str1, chr1, str2, chr2)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1, str2
character(len=*), intent(in) :: chr1, chr2
call check(error, lgt(str1, str2) .eqv. lgt(chr1, chr2))
if (allocated(error)) return
call check(error, lgt(str1, chr2) .eqv. lgt(chr1, chr2))
if (allocated(error)) return
call check(error, lgt(chr1, str2) .eqv. lgt(chr1, chr2))
end subroutine gen_lgt
subroutine test_lgt(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = lgt(string, "abc")
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = lgt(string, "bcd")
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = lgt(string, "cde")
call check(error, res .eqv. .false.)
if (allocated(error)) return
call check2(error, "bcd", "abc", gen_lgt)
if (allocated(error)) return
call check2(error, "bcd", "bcd", gen_lgt)
if (allocated(error)) return
call check2(error, "bcd", "cde", gen_lgt)
end subroutine test_lgt
!> Generator for checking the lexical comparison
subroutine gen_llt(error, str1, chr1, str2, chr2)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1, str2
character(len=*), intent(in) :: chr1, chr2
call check(error, llt(str1, str2) .eqv. llt(chr1, chr2))
if (allocated(error)) return
call check(error, llt(str1, chr2) .eqv. llt(chr1, chr2))
if (allocated(error)) return
call check(error, llt(chr1, str2) .eqv. llt(chr1, chr2))
end subroutine gen_llt
subroutine test_llt(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = llt(string, "abc")
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = llt(string, "bcd")
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = llt(string, "cde")
call check(error, res .eqv. .true.)
if (allocated(error)) return
call check2(error, "bcd", "abc", gen_llt)
if (allocated(error)) return
call check2(error, "bcd", "bcd", gen_llt)
if (allocated(error)) return
call check2(error, "bcd", "cde", gen_llt)
end subroutine test_llt
!> Generator for checking the lexical comparison
subroutine gen_lge(error, str1, chr1, str2, chr2)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1, str2
character(len=*), intent(in) :: chr1, chr2
call check(error, lge(str1, str2) .eqv. lge(chr1, chr2))
if (allocated(error)) return
call check(error, lge(str1, chr2) .eqv. lge(chr1, chr2))
if (allocated(error)) return
call check(error, lge(chr1, str2) .eqv. lge(chr1, chr2))
end subroutine gen_lge
subroutine test_lge(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = lge(string, "abc")
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = lge(string, "bcd")
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = lge(string, "cde")
call check(error, res .eqv. .false.)
if (allocated(error)) return
call check2(error, "bcd", "abc", gen_lge)
if (allocated(error)) return
call check2(error, "bcd", "bcd", gen_lge)
if (allocated(error)) return
call check2(error, "bcd", "cde", gen_lge)
end subroutine test_lge
!> Generator for checking the lexical comparison
subroutine gen_lle(error, str1, chr1, str2, chr2)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1, str2
character(len=*), intent(in) :: chr1, chr2
call check(error, lle(str1, str2) .eqv. lle(chr1, chr2))
if (allocated(error)) return
call check(error, lle(str1, chr2) .eqv. lle(chr1, chr2))
if (allocated(error)) return
call check(error, lle(chr1, str2) .eqv. lle(chr1, chr2))
end subroutine gen_lle
subroutine test_lle(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
logical :: res
string = "bcd"
res = lle(string, "abc")
call check(error, res .eqv. .false.)
if (allocated(error)) return
res = lle(string, "bcd")
call check(error, res .eqv. .true.)
if (allocated(error)) return
res = lle(string, "cde")
call check(error, res .eqv. .true.)
if (allocated(error)) return
call check2(error, "bcd", "abc", gen_lle)
if (allocated(error)) return
call check2(error, "bcd", "bcd", gen_lle)
if (allocated(error)) return
call check2(error, "bcd", "cde", gen_lle)
end subroutine test_lle
!> Generator for checking the trimming of whitespace
subroutine gen_trim(error, str1, chr1)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1
character(len=*), intent(in) :: chr1
call check(error, len(trim(str1)) == len(trim(chr1)))
end subroutine gen_trim
subroutine test_trim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string, trimmed_str
string = "Whitespace "
trimmed_str = trim(string)
call check(error, len(trimmed_str) == 10)
if (allocated(error)) return
call check1(error, " Whitespace ", gen_trim)
if (allocated(error)) return
call check1(error, " W h i t e s p a ce ", gen_trim)
if (allocated(error)) return
call check1(error, "SPACE SPACE", gen_trim)
if (allocated(error)) return
call check1(error, " ", gen_trim)
end subroutine test_trim
!> Generator for checking the length of the character sequence
subroutine gen_len(error, str1, chr1)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1
character(len=*), intent(in) :: chr1
call check(error, len(str1) == len(chr1))
end subroutine gen_len
subroutine test_len(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: length
string = "Some longer sentence for this example."
length = len(string)
call check(error, length == 38)
if (allocated(error)) return
string = "Whitespace "
length = len(string)
call check(error, length == 38)
if (allocated(error)) return
call check1(error, "Example string", gen_len)
if (allocated(error)) return
call check1(error, "S P A C E D S T R I N G", gen_len)
if (allocated(error)) return
call check1(error, "With trailing whitespace ", gen_len)
if (allocated(error)) return
call check1(error, " centered ", gen_len)
end subroutine test_len
!> Generator for checking the length of the character sequence without whitespace
subroutine gen_len_trim(error, str1, chr1)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1
character(len=*), intent(in) :: chr1
call check(error, len_trim(str1) == len_trim(chr1))
end subroutine gen_len_trim
subroutine test_len_trim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: length
string = "Some longer sentence for this example."
length = len_trim(string)
call check(error, length == 38)
if (allocated(error)) return
string = "Whitespace "
length = len_trim(string)
call check(error, length == 10)
if (allocated(error)) return
call check1(error, "Example string", gen_len_trim)
if (allocated(error)) return
call check1(error, "S P A C E D S T R I N G", gen_len_trim)
if (allocated(error)) return
call check1(error, "With trailing whitespace ", gen_len_trim)
if (allocated(error)) return
call check1(error, " centered ", gen_len_trim)
end subroutine test_len_trim
!> Generator for checking the left adjustment of the character sequence
subroutine gen_adjustl(error, str1, chr1)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1
character(len=*), intent(in) :: chr1
call check(error, adjustl(str1) == adjustl(chr1))
end subroutine gen_adjustl
subroutine test_adjustl(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
string = " Whitespace"
string = adjustl(string)
call check(error, char(string) == "Whitespace ")
if (allocated(error)) return
call check1(error, " B L A N K S ", gen_adjustl)
end subroutine test_adjustl
!> Generator for checking the right adjustment of the character sequence
subroutine gen_adjustr(error, str1, chr1)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1
character(len=*), intent(in) :: chr1
call check(error, adjustr(str1) == adjustr(chr1))
end subroutine gen_adjustr
subroutine test_adjustr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
string = "Whitespace "
string = adjustr(string)
call check(error, char(string) == " Whitespace")
if (allocated(error)) return
call check1(error, " B L A N K S ", gen_adjustr)
end subroutine test_adjustr
!> Generator for checking the presence of a character set in a character sequence
subroutine gen_scan(error, str1, chr1, str2, chr2)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1, str2
character(len=*), intent(in) :: chr1, chr2
call check(error, scan(str1, str2) == scan(chr1, chr2))
if (allocated(error)) return
call check(error, scan(str1, chr2) == scan(chr1, chr2))
if (allocated(error)) return
call check(error, scan(chr1, str2) == scan(chr1, chr2))
if (allocated(error)) return
call check(error, scan(str1, str2, back=.true.) == scan(chr1, chr2, back=.true.))
if (allocated(error)) return
call check(error, scan(str1, chr2, back=.true.) == scan(chr1, chr2, back=.true.))
if (allocated(error)) return
call check(error, scan(chr1, str2, back=.true.) == scan(chr1, chr2, back=.true.))
end subroutine gen_scan
subroutine test_scan(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: pos
string = "fortran"
pos = scan(string, "ao")
call check(error, pos == 2)
if (allocated(error)) return
pos = scan(string, "ao", .true.)
call check(error, pos == 6)
if (allocated(error)) return
pos = scan(string, "c++")
call check(error, pos == 0)
if (allocated(error)) return
call check2(error, "fortran", "ao", gen_scan)
if (allocated(error)) return
call check2(error, "c++", "fortran", gen_scan)
end subroutine test_scan
!> Generator for checking the absence of a character set in a character sequence
subroutine gen_verify(error, str1, chr1, str2, chr2)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1, str2
character(len=*), intent(in) :: chr1, chr2
call check(error, verify(str1, str2) == verify(chr1, chr2))
if (allocated(error)) return
call check(error, verify(str1, chr2) == verify(chr1, chr2))
if (allocated(error)) return
call check(error, verify(chr1, str2) == verify(chr1, chr2))
if (allocated(error)) return
call check(error, verify(str1, str2, back=.true.) == verify(chr1, chr2, back=.true.))
if (allocated(error)) return
call check(error, verify(str1, chr2, back=.true.) == verify(chr1, chr2, back=.true.))
if (allocated(error)) return
call check(error, verify(chr1, str2, back=.true.) == verify(chr1, chr2, back=.true.))
end subroutine gen_verify
subroutine test_verify(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: pos
string = "fortran"
pos = verify(string, "ao")
call check(error, pos == 1)
if (allocated(error)) return
pos = verify(string, "fo")
call check(error, pos == 3)
if (allocated(error)) return
pos = verify(string, "c++")
call check(error, pos == 1)
if (allocated(error)) return
pos = verify(string, "c++", back=.true.)
call check(error, pos == 7)
if (allocated(error)) return
pos = verify(string, string)
call check(error, pos == 0)
if (allocated(error)) return
call check2(error, "fortran", "ao", gen_verify)
if (allocated(error)) return
call check2(error, "c++", "fortran", gen_verify)
end subroutine test_verify
!> Generator for the repeatition of a character sequence
subroutine gen_repeat(error, str1, chr1)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1
character(len=*), intent(in) :: chr1
integer :: i
do i = 12, 3, -2
call check(error, repeat(str1, i) == repeat(chr1, i))
if (allocated(error)) return
end do
end subroutine gen_repeat
subroutine test_repeat(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
string = "What? "
string = repeat(string, 3)
call check(error, string == "What? What? What? ")
if (allocated(error)) return
call check1(error, "!!1!", gen_repeat)
if (allocated(error)) return
call check1(error, "This sentence is repeated multiple times. ", gen_repeat)
end subroutine test_repeat
!> Generator for checking the substring search in a character string
subroutine gen_index(error, str1, chr1, str2, chr2)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type), intent(in) :: str1, str2
character(len=*), intent(in) :: chr1, chr2
call check(error, index(str1, str2) == index(chr1, chr2))
if (allocated(error)) return
call check(error, index(str1, chr2) == index(chr1, chr2))
if (allocated(error)) return
call check(error, index(chr1, str2) == index(chr1, chr2))
if (allocated(error)) return
call check(error, index(str1, str2, back=.true.) == index(chr1, chr2, back=.true.))
if (allocated(error)) return
call check(error, index(str1, chr2, back=.true.) == index(chr1, chr2, back=.true.))
if (allocated(error)) return
call check(error, index(chr1, str2, back=.true.) == index(chr1, chr2, back=.true.))
end subroutine gen_index
subroutine test_index(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: pos
string = "Search this string for this expression"
pos = index(string, "this")
call check(error, pos == 8)
if (allocated(error)) return
pos = index(string, "this", back=.true.)
call check(error, pos == 24)
if (allocated(error)) return
pos = index(string, "This")
call check(error, pos == 0)
if (allocated(error)) return
call check2(error, "Search this string for this expression", "this", gen_index)
if (allocated(error)) return
call check2(error, "Search this string for this expression", "This", gen_index)
end subroutine test_index
subroutine test_char(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
character(len=:), allocatable :: dlc
character(len=1), allocatable :: chars(:)
string = "Character sequence"
dlc = char(string)
call check(error, dlc == "Character sequence")
if (allocated(error)) return
dlc = char(string, 3)
call check(error, dlc == "a")
if (allocated(error)) return
chars = char(string, [3, 5, 8, 12, 14, 15, 18])
call check(error, all(chars == ["a", "a", "e", "e", "u", "e", "e"]))
if (allocated(error)) return
string = "Fortran"
dlc = char(string, 1, 4)
call check(error, dlc == "Fort")
end subroutine test_char
subroutine test_ichar(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: code
string = "Fortran"
code = ichar(string)
call check(error, code == ichar("F"))
end subroutine test_ichar
subroutine test_iachar(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: string
integer :: code
string = "Fortran"
code = iachar(string)
call check(error, code == iachar("F"))
end subroutine test_iachar
subroutine test_move(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(string_type) :: from_string, to_string
type(string_type) :: from_string_not
type(string_type) :: from_strings(2), to_strings(2)
character(len=:), allocatable :: from_char, to_char
from_string = "Move This String"
from_strings = "Move This String"
from_char = "Move This Char"
call check(error, from_string == "Move This String" .and. to_string == "" .and. &
& from_char == "Move This Char" .and. .not. allocated(to_char), &
& "move: test_case 1")
if (allocated(error)) return
! string_type (allocated) --> string_type (not allocated)
call move(from_string, to_string)
call check(error, from_string == "" .and. to_string == "Move This String", "move: test_case 2")
if (allocated(error)) return
! character (allocated) --> string_type (not allocated)
call move(from_char, from_string)
call check(error, .not. allocated(from_char) .and. from_string == "Move This Char", &
& "move: test_case 3")
if (allocated(error)) return
! string_type (allocated) --> character (not allocated)
call move(to_string, to_char)
call check(error, to_string == "" .and. to_char == "Move This String", "move: test_case 4")
if (allocated(error)) return
! character (allocated) --> string_type (allocated)
call move(to_char, from_string)
call check(error, .not. allocated(to_char) .and. from_string == "Move This String", &
& "move: test_case 5")
if (allocated(error)) return
from_char = "new char"
! character (allocated) --> string_type (allocated)
call move(from_char, from_string)
call check(error, .not. allocated(from_char) .and. from_string == "new char", "move: test_case 6")
if (allocated(error)) return
! character (not allocated) --> string_type (allocated)
call move(from_char, from_string)
call check(error, from_string == "", "move: test_case 7")
if (allocated(error)) return
from_string = "moving to self"
! string_type (allocated) --> string_type (allocated)
call move(from_string, from_string)
call check(error, from_string == "moving to self", "move: test_case 8")
if (allocated(error)) return
! elemental: string_type (allocated) --> string_type (not allocated)
call move(from_strings, to_strings)
call check(error, all(from_strings(:) == "") .and. all(to_strings(:) == "Move This String"), "move: test_case 9")
! string_type (not allocated) --> string_type (not allocated)
call move(from_string_not, to_string)
call check(error, from_string_not == "" .and. to_string == "", "move: test_case 10")
if (allocated(error)) return
! string_type (not allocated) --> string_type (not allocated)
to_string = "to be deallocated"
call move(from_string_not, to_string)
call check(error, from_string_not == "" .and. to_string == "", "move: test_case 11")
if (allocated(error)) return
end subroutine test_move
end module test_string_intrinsic
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_string_intrinsic, only : collect_string_intrinsic
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("string-intrinsic", collect_string_intrinsic) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/string/test_string_to_string.f90 0000664 0001750 0001750 00000023737 15135654166 025444 0 ustar alastair alastair ! SPDX-Identifier: MIT
module test_string_to_string
use stdlib_strings, only: to_string, to_c_char, starts_with
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_optval, only: optval
implicit none
contains
!> Collect all exported unit tests
subroutine collect_string_to_string(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("to_string-complex", test_to_string_complex), &
new_unittest("to_string-integer", test_to_string_integer), &
new_unittest("to_string-logical", test_to_string_logical), &
new_unittest("to_string-real", test_to_string_real), &
new_unittest("to_string-limit-i1", test_string_i1), &
new_unittest("to_string-limit-i2", test_string_i2), &
new_unittest("to_string-limit-i4", test_string_i4), &
new_unittest("to_string-limit-i8", test_string_i8), &
new_unittest("to_c_char", test_to_c_char) &
]
end subroutine collect_string_to_string
subroutine check_formatter(error, actual, expected, description, partial)
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: actual, expected, description
logical, intent(in), optional :: partial
logical :: stat
character(len=:), allocatable :: msg
if (optval(partial, .false.)) then
stat = starts_with(actual, expected)
else
stat = actual == expected
end if
if (.not. stat) then
msg = description // new_line("a") // &
& "Expected: '" // expected // "' but got '" // actual // "'"
else
print '(" - ", a, /, " Result: ''", a, "''")', description, actual
end if
call check(error, stat, msg)
end subroutine check_formatter
subroutine test_to_string_complex(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check_formatter(error, to_string((1, 1)), "(1.0", &
& "Default formatter for complex number", partial=.true.)
if (allocated(error)) return
call check_formatter(error, to_string((1, 1), '(F6.2)'), "( 1.00, 1.00)", &
& "Formatter for complex number")
if (allocated(error)) return
call check_formatter(error, to_string((-1, -1), 'F6.2'), "( -1.00, -1.00)", &
& "Formatter for negative complex number")
if (allocated(error)) return
call check_formatter(error, to_string((1, 1), 'SP,F6.2'), "( +1.00, +1.00)", &
& "Formatter with sign control descriptor for complex number")
if (allocated(error)) return
call check_formatter(error, to_string((1, 1), 'F6.2') // to_string((2, 2), '(F7.3)'), &
& "( 1.00, 1.00)( 2.000, 2.000)", &
& "Multiple formatters for complex numbers")
end subroutine test_to_string_complex
subroutine test_to_string_integer(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check_formatter(error, to_string(100), "100", &
& "Default formatter for integer number")
if (allocated(error)) return
call check_formatter(error, to_string(100, 'I6'), " 100", &
& "Formatter for integer number")
if (allocated(error)) return
call check_formatter(error, to_string(100, 'I0.6'), "000100", &
& "Formatter with zero padding for integer number")
if (allocated(error)) return
call check_formatter(error, to_string(100, 'I6') // to_string(1000, '(I7)'), &
& " 100 1000", "Multiple formatters for integers")
if (allocated(error)) return
call check_formatter(error, to_string(34, 'B8'), " 100010", &
& "Binary formatter for integer number")
if (allocated(error)) return
call check_formatter(error, to_string(34, 'O0.3'), "042", &
& "Octal formatter with zero padding for integer number")
if (allocated(error)) return
call check_formatter(error, to_string(34, 'Z3'), " 22", &
& "Hexadecimal formatter for integer number")
end subroutine test_to_string_integer
subroutine test_to_string_real(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check_formatter(error, to_string(100.), "100.0", &
& "Default formatter for real number", partial=.true.)
if (allocated(error)) return
call check_formatter(error, to_string(100., 'F6.2'), "100.00", &
& "Formatter for real number")
if (allocated(error)) return
call check_formatter(error, to_string(289., 'E7.2'), ".29E+03", &
& "Exponential formatter with rounding for real number")
if (allocated(error)) return
call check_formatter(error, to_string(128., 'ES8.2'), "1.28E+02", &
& "Exponential formatter for real number")
if (allocated(error)) return
! Wrong demonstration
call check_formatter(error, to_string(-100., 'F6.2'), "*", &
& "Too narrow formatter for signed real number", partial=.true.)
if (allocated(error)) return
call check_formatter(error, to_string(1000., 'F6.3'), "*", &
& "Too narrow formatter for real number", partial=.true.)
if (allocated(error)) return
call check_formatter(error, to_string(1000., '7.3'), "[*]", &
& "Invalid formatter for real number", partial=.true.)
if (allocated(error)) return
end subroutine test_to_string_real
subroutine test_to_string_logical(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check_formatter(error, to_string(.true.), "T", &
& "Default formatter for logcal value")
if (allocated(error)) return
call check_formatter(error, to_string(.true., 'L2'), " T", &
& "Formatter for logical value")
if (allocated(error)) return
call check_formatter(error, to_string(.false., 'L2') // to_string(.true., '(L5)'), &
& " F T", "Multiple formatters for logical values")
if (allocated(error)) return
! Wrong demonstration
call check_formatter(error, to_string(.false., '1x'), "[*]", &
& "Invalid formatter for logical value", partial=.true.)
end subroutine test_to_string_logical
subroutine test_to_c_char(error)
use stdlib_kinds, only : c_char
use stdlib_string_type, only: string_type, len, char
use iso_c_binding, only: c_size_t
!> Error handling
type(error_type), allocatable, intent(out) :: error
!> Interface to C standard library
interface
integer(c_size_t) function c_strlen(cstr) bind(C, name="strlen") result(len)
import :: c_char, c_size_t
character(kind=c_char), intent(in) :: cstr(*)
end function c_strlen
end interface
type(string_type) :: shello
character(kind=c_char), allocatable :: cstr(:)
character(*), parameter :: hello = "Hello, World!"
integer :: i
! Convert character array
cstr = to_c_char(hello)
call check(error, len(hello)==c_strlen(cstr), 'to_c_char_from_char: invalid C length')
if (allocated(error)) return
do i=1,len(hello)
call check(error, hello(i:i)==cstr(i), 'to_c_char_from_char: character mismatch')
if (allocated(error)) return
end do
! Convert string type
shello = string_type(hello)
cstr = to_c_char(shello)
call check(error, len(shello)==c_strlen(cstr), 'to_c_char_from_string: invalid C length')
if (allocated(error)) return
do i=1,len(shello)
call check(error, char(shello,pos=i)==cstr(i), 'to_c_char_from_string: character mismatch')
if (allocated(error)) return
end do
end subroutine test_to_c_char
subroutine test_string_i1(error)
use stdlib_kinds, only : i1 => int8
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, to_string(-huge(1_i1) - 1_i1), "-128")
end subroutine test_string_i1
subroutine test_string_i2(error)
use stdlib_kinds, only : i2 => int16
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, to_string(-huge(1_i2) - 1_i2), "-32768")
end subroutine test_string_i2
subroutine test_string_i4(error)
use stdlib_kinds, only : i4 => int32
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, to_string(-huge(1_i4) - 1_i4), "-2147483648")
end subroutine test_string_i4
subroutine test_string_i8(error)
use stdlib_kinds, only : i8 => int64
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, to_string(-huge(1_i8) - 1_i8), "-9223372036854775808")
end subroutine test_string_i8
end module test_string_to_string
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_string_to_string, only : collect_string_to_string
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("string-to_string", collect_string_to_string) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/math/ 0000775 0001750 0001750 00000000000 15135654166 020076 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/math/test_logspace.f90 0000664 0001750 0001750 00000021605 15135654166 023256 0 ustar alastair alastair module test_logspace
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_kinds, only: sp, dp, int8, int16, int32, int64
use stdlib_math, only: logspace, DEFAULT_LOGSPACE_BASE, DEFAULT_LOGSPACE_LENGTH
implicit none
! Testing logspace
!
! logspace should return a rank 1 array of values equally logarithmically spaced
! from the base**start to base**end, using 10 as the base. If no length
! is specified, return a rank 1 array with 50 elements.
!
! Also test to verify that the proportion between adjacent elements is constant within
! a certain tolerance
real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp)
real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed
contains
!> Collect all exported unit tests
subroutine collect_logspace(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("logspace_sp", test_logspace_sp), &
new_unittest("logspace_dp", test_logspace_dp), &
new_unittest("logspace_default", test_logspace_default), &
new_unittest("logspace_base_2", test_logspace_base_2), &
new_unittest("logspace_base_2_cmplx_start", test_logspace_base_2_cmplx_start), &
new_unittest("logspace_base_i_int_start", test_logspace_base_i_int_start) &
]
end subroutine collect_logspace
subroutine test_logspace_sp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 20
real(sp), parameter :: start = 0.0_sp
real(sp), parameter :: end = 2.0_sp
real(sp) :: expected_proportion
integer :: i
real(sp), allocatable :: x(:)
x = logspace(start, end, n)
expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )
call check(error, size(x), n, "Array not allocated to appropriate size")
if (allocated(error)) return
call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start")
if (allocated(error)) return
call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end")
if (allocated(error)) return
do i = 1, n-1
call check(error, x(i + 1) / x(i), expected_proportion, &
& thr=abs(expected_proportion) * TOLERANCE_SP)
if (allocated(error)) return
end do
end subroutine
subroutine test_logspace_dp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
real(dp), parameter :: start = 1.0_dp
real(dp), parameter :: end = 0.0_dp
real(dp) :: expected_proportion
integer :: i
real(dp), allocatable :: x(:)
x = logspace(start, end, n)
expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )
call check(error, size(x), n, "Array not allocated to appropriate size")
if (allocated(error)) return
call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start")
if (allocated(error)) return
call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end")
if (allocated(error)) return
do i = 1, n-1
call check(error, x(i + 1) / x(i), expected_proportion, &
& thr=abs(expected_proportion) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_logspace_default(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp), parameter :: start = 0.0_dp
real(dp), parameter :: end = 1.0_dp
integer, parameter :: n = DEFAULT_LOGSPACE_LENGTH
real(dp) :: expected_proportion
integer :: i
real(dp), allocatable :: x(:)
x = logspace(start, end)
expected_proportion = 10 ** ( ( end - start ) / ( n - 1 ) )
call check(error, size(x), n, "Array not allocated to appropriate size")
if (allocated(error)) return
call check(error, x(1), DEFAULT_LOGSPACE_BASE ** start, "Initial value of array is not equal to 10^start")
if (allocated(error)) return
call check(error, x(n), DEFAULT_LOGSPACE_BASE ** end, "Final value of array is not equal to 10^end")
if (allocated(error)) return
do i = 1, n-1
call check(error, x(i + 1) / x(i), expected_proportion, &
& thr=abs(expected_proportion) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_logspace_base_2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
real(dp), parameter :: start = 1.0_dp
real(dp), parameter :: end = 10.0_dp
integer, parameter :: base = 2
integer :: i
real(dp) :: expected_proportion
real(dp), allocatable :: x(:)
x = logspace(start, end, n, base)
expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) )
call check(error, size(x), n, "Array not allocated to appropriate size")
if (allocated(error)) return
call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start")
if (allocated(error)) return
call check(error, x(n), base ** end, "Final value of array is not equal to 2^end")
if (allocated(error)) return
do i = 1, n-1
call check(error, x(i + 1) / x(i), expected_proportion, &
& thr=abs(expected_proportion) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_logspace_base_2_cmplx_start(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 10
complex(dp), parameter :: start = (1, 0)
complex(dp), parameter :: end = (0, 1)
integer, parameter :: base = 2
complex(dp) :: expected_proportion
integer :: i
complex(dp), allocatable :: x(:)
x = logspace(start, end, n, base)
expected_proportion = 2 ** ( ( end - start ) / ( n - 1 ) )
call check(error, size(x), n, "Array not allocated to appropriate size")
if (allocated(error)) return
call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start")
if (allocated(error)) return
call check(error, x(n), base ** end, "Final value of array is not equal to 2^end")
if (allocated(error)) return
do i = 1, n-1
call check(error, x(i + 1) / x(i), expected_proportion, &
& thr=abs(expected_proportion) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_logspace_base_i_int_start(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 5
integer, parameter :: start = 1
integer, parameter :: end = 5
complex(dp), parameter :: base = (0, 1) ! i
complex(dp) :: expected_proportion
integer :: i
complex(dp), allocatable :: x(:)
x = logspace(start, end, n, base)
expected_proportion = base ** ( ( end - start ) / ( n - 1 ) )
call check(error, size(x), n, "Array not allocated to appropriate size")
if (allocated(error)) return
call check(error, x(1), base ** start, "Initial value of array is not equal to 2^start")
if (allocated(error)) return
call check(error, x(n), base ** end, "Final value of array is not equal to 2^end")
if (allocated(error)) return
do i = 1, n-1
call check(error, x(i + 1) / x(i), expected_proportion, &
& thr=abs(expected_proportion) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_logspace, only : collect_logspace
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("logspace", collect_logspace) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/math/test_linspace.f90 0000664 0001750 0001750 00000034627 15135654166 023267 0 ustar alastair alastair module test_linspace
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_kinds, only: sp, dp, int8, int16
use stdlib_math, only: linspace, DEFAULT_LINSPACE_LENGTH
implicit none
private
public :: collect_linspace
real(sp), parameter :: TOLERANCE_SP = 1000 * epsilon(1.0_sp)
real(dp), parameter :: TOLERANCE_DP = 1000 * epsilon(1.0_dp) ! Percentage of the range for which the actual gap must not exceed
! Testing linspace.
!
! For single and double precision, check if the beginning and end values are properly recorded
! and make sure that the size of the result array is as expected.
!
! This testing suite makes use of the a repeated section of code that will check to make
! sure that every element is linearly spaced (i.e., call check(|array(i+1) - array(i)| < |expected_value| * TOLERANCE)).
! I would convert this repeated code into a subroutine but that would require the implementation of a
! generic procedure given that each linear space will have a different expected_value type and kind.
contains
!> Collect all exported unit tests
subroutine collect_linspace(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("linspace_sp", test_linspace_sp), &
new_unittest("linspace_dp", test_linspace_dp), &
new_unittest("linspace_neg_index", test_linspace_neg_index), &
new_unittest("linspace_cmplx", test_linspace_cmplx), &
new_unittest("linspace_cmplx_2", test_linspace_cmplx_2), &
new_unittest("linspace_cmplx_3", test_linspace_cmplx_3), &
new_unittest("linspace_cmplx_sp", test_linspace_cmplx_sp), &
new_unittest("linspace_cmplx_sp_2", test_linspace_cmplx_sp_2), &
new_unittest("linspace_int16", test_linspace_int16), &
new_unittest("linspace_int8", test_linspace_int8) &
]
end subroutine collect_linspace
subroutine test_linspace_sp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 20
real(sp), parameter :: start = 1.0_sp
real(sp), parameter :: end = 10.0_sp
real(sp) :: expected_interval
real(sp) :: true_difference
integer :: i
real(sp), allocatable :: x(:)
x = linspace(start, end, n)
expected_interval =( end - start ) / real(( n - 1 ), sp)
call check(error, x(1), start, "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, x(n), end, "Final array value is not equal to end parameter")
if (allocated(error)) return
call check(error, size(x), n, "Array not allocated to appropriate size")
if (allocated(error)) return
print *, "Made it through first round of tests"
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
true_difference = x(i + 1) - x(i)
call check(error, abs(true_difference - expected_interval) < abs(expected_interval) * TOLERANCE_SP)
if (allocated(error)) return
end do
end subroutine
subroutine test_linspace_dp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp), parameter :: start = 1.0_dp
real(dp), parameter :: end = 10.0_dp
integer, parameter :: n = DEFAULT_LINSPACE_LENGTH
real(dp) :: expected_interval
real(dp) :: true_difference
real(dp), allocatable :: x(:)
integer :: i
x = linspace(start, end)
expected_interval =( end - start ) / ( n - 1 )
call check(error, size(x), n, "Array not allocated to default size")
if (allocated(error)) return
call check(error, x(1), start, "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, x(n), end, "Final array value is not equal to end parameter")
if (allocated(error)) return
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
true_difference = x(i + 1) - x(i)
call check(error, true_difference, expected_interval, &
& thr=abs(expected_interval) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_linspace_neg_index(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp), parameter :: start = 1.0_dp
real(dp), parameter :: end = 10.0_dp
real(dp), allocatable :: x(:)
x = linspace(start, end, -15)
call check(error, size(x), 0, "Allocated array is not empty")
end subroutine
subroutine test_linspace_cmplx(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(dp), parameter :: start = (0.0_dp, 10.0_dp)
complex(dp), parameter :: end = (1.0_dp, 0.0_dp)
complex(dp) :: expected_interval
integer, parameter :: n = 10
complex(dp), allocatable :: z(:)
integer :: i
z = linspace(start, end, n)
expected_interval =( end - start ) / ( n - 1 )
call check(error, size(z), n, "Array not allocated to correct size")
if (allocated(error)) return
call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, z(n), end, "Final array value is not equal to end parameter")
if (allocated(error)) return
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
call check(error, z(i + 1) - z(i), expected_interval, &
& thr=abs(expected_interval) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_linspace_cmplx_2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(dp), parameter :: start = (10.0_dp, 10.0_dp)
complex(dp), parameter :: end = (1.0_dp, 1.0_dp)
complex(dp) :: expected_interval
integer, parameter :: n = 5
complex(dp), allocatable :: z(:)
integer :: i
z = linspace(start, end, n)
expected_interval =( end - start ) / ( n - 1 )
call check(error, size(z), n, "Array not allocated to correct size")
if (allocated(error)) return
call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, z(n), end, "Final array value is not equal to end parameter")
if (allocated(error)) return
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
call check(error, z(i + 1) - z(i), expected_interval, &
& thr=abs(expected_interval) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_linspace_cmplx_3(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(dp), parameter :: start = (-5.0_dp, 100.0_dp)
complex(dp), parameter :: end = (20.0_dp, 13.0_dp)
complex(dp) :: expected_interval
integer, parameter :: n = 20
complex(dp), allocatable :: z(:)
integer :: i
z = linspace(start, end, n)
expected_interval = ( end - start ) / ( n - 1 )
call check(error, size(z), n, "Array not allocated to correct size")
if (allocated(error)) return
call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, z(n), end, "Final array value is not equal to end parameter")
if (allocated(error)) return
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
call check(error, z(i + 1) - z(i), expected_interval, &
& thr=abs(expected_interval) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_linspace_cmplx_sp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(sp), parameter :: start = (0.5_sp, 5.0_sp)
complex(sp), parameter :: end = (1.0_sp, -30.0_sp)
complex(sp) :: expected_interval
integer, parameter :: n = 10
complex(sp), allocatable :: z(:)
integer :: i
z = linspace(start, end, n)
expected_interval =( end - start ) / ( n - 1 )
call check(error, size(z), n, "Array not allocated to correct size")
if (allocated(error)) return
call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, z(n), end, "Final array value is not equal to end parameter")
if (allocated(error)) return
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
call check(error, z(i + 1) - z(i), expected_interval, &
& thr=abs(expected_interval) * TOLERANCE_SP)
if (allocated(error)) return
end do
end subroutine
subroutine test_linspace_cmplx_sp_2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(sp), parameter :: start = (50.0_sp, 500.0_sp)
complex(sp), parameter :: end = (-100.0_sp, 2000.0_sp)
complex(sp) :: expected_interval
complex(sp) :: true_interval
real(sp) :: offset
integer, parameter :: n = DEFAULT_LINSPACE_LENGTH
complex(sp), allocatable :: z(:)
integer :: i
z = linspace(start, end)
expected_interval =( end - start ) / ( n - 1 )
call check(error, size(z), n, "Array not allocated to default size")
if (allocated(error)) return
call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, z(n), end, "Final array value is not equal to end parameter")
if (allocated(error)) return
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
true_interval = (z(i + 1) - z(i))
offset = abs(true_interval - expected_interval)
call check(error, z(i + 1) - z(i), expected_interval, &
& thr=abs(expected_interval) * TOLERANCE_SP)
if (allocated(error)) return
! print *, i
end do
end subroutine
subroutine test_linspace_int16(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int16), parameter :: start = 5
integer(int16), parameter :: end = 10
real(dp) :: expected_interval
integer, parameter :: n = 6
integer(int16), allocatable :: z(:)
integer :: i
z = linspace(start, end, n)
expected_interval =( end - start ) / ( n - 1 )
call check(error, size(z), n, "Array not allocated to correct size")
if (allocated(error)) return
call check(error, z(1), start, "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, z(n), end, "Final array value is not equal to end parameter")
if (allocated(error)) return
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
call check(error, real(z(i + 1) - z(i), dp), expected_interval, &
& thr=abs(expected_interval) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
subroutine test_linspace_int8(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int8), parameter :: start = 20
integer(int8), parameter :: end = 50
real(dp) :: expected_interval
integer, parameter :: n = 10
real(dp), allocatable :: z(:)
integer(int8) :: z_int(n)
integer :: i
z = linspace(start, end, n)
z_int = linspace(start, end, n)
expected_interval =real( end - start, dp ) / ( n - 1 )
call check(error, size(z), n, "Array not allocated to correct size")
if (allocated(error)) return
call check(error, z(1), real(start, dp), "Initial value of array is not equal to the passed start parameter")
if (allocated(error)) return
call check(error, z(n), real(end, dp), "Final array value is not equal to end parameter")
if (allocated(error)) return
! Due to roundoff error, it is possible that the jump from x(n-1) to x(n) is slightly different than the expected interval
do i = 1, n-1
call check(error, z(i + 1) - z(i), expected_interval, &
& thr=abs(expected_interval) * TOLERANCE_DP)
if (allocated(error)) return
end do
end subroutine
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_linspace, only : collect_linspace
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("linspace", collect_linspace) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/math/CMakeLists.txt 0000664 0001750 0001750 00000000406 15135654166 022636 0 ustar alastair alastair set(
fppFiles
"test_meshgrid.fypp"
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
set(
cppFiles
"test_stdlib_math.fypp"
)
fypp_f90pp("${fyppFlags}" "${cppFiles}" outFiles)
ADDTESTPP(stdlib_math)
ADDTEST(linspace)
ADDTEST(logspace)
ADDTEST(meshgrid)
fortran-lang-stdlib-0ede301/test/math/test_stdlib_math.fypp 0000664 0001750 0001750 00000100666 15135654166 024340 0 ustar alastair alastair ! SPDX-Identifier: MIT
#:include "common.fypp"
module test_stdlib_math
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_math, only: clip, swap, arg, argd, argpi, arange, is_close, all_close, diff, &
arange, deg2rad, rad2deg
use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
implicit none
public :: collect_stdlib_math
#:for k1 in REAL_KINDS
real(kind=${k1}$), parameter :: PI_${k1}$ = acos(-1.0_${k1}$)
#:endfor
contains
!> Collect all exported unit tests
subroutine collect_stdlib_math(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("clip-int8", test_clip_int8), &
new_unittest("clip-int8-bounds", test_clip_int8_bounds), &
new_unittest("clip-int16", test_clip_int16), &
new_unittest("clip-int16-bounds", test_clip_int16_bounds), &
new_unittest("clip-int32", test_clip_int32), &
new_unittest("clip-int32-bounds", test_clip_int32_bounds), &
new_unittest("clip-int64", test_clip_int64), &
new_unittest("clip-int64-bounds", test_clip_int64_bounds), &
new_unittest("clip-real-single", test_clip_rsp), &
new_unittest("clip-real-single-bounds", test_clip_rsp_bounds), &
new_unittest("clip-real-double", test_clip_rdp), &
new_unittest("clip-real-double-bounds", test_clip_rdp_bounds), &
new_unittest("clip-real-quad", test_clip_rqp), &
new_unittest("clip-real-quad-bounds", test_clip_rqp_bounds) &
!> Tests swap
#:for k1, t1 in INT_KINDS_TYPES + REAL_KINDS_TYPES
, new_unittest("swap_${k1}$", test_swap_${k1}$) &
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
, new_unittest("swap_c${k1}$", test_swap_c${k1}$) &
#:endfor
, new_unittest("swap_str", test_swap_str) &
, new_unittest("swap_stt", test_swap_stt) &
!> Tests for arg/argd/argpi
#:for k1 in CMPLX_KINDS
, new_unittest("arg-cmplx-${k1}$", test_arg_${k1}$) &
, new_unittest("argd-cmplx-${k1}$", test_argd_${k1}$) &
, new_unittest("argpi-cmplx-${k1}$", test_argpi_${k1}$) &
#:endfor
!> Tests for deg2rad/rad2deg
#:for k1 in REAL_KINDS
, new_unittest("deg2rad-real-${k1}$", test_deg2rad_${k1}$) &
, new_unittest("rad2deg-real-${k1}$", test_rad2deg_${k1}$) &
#:endfor
!> Tests for `is_close` and `all_close`
#:for k1 in REAL_KINDS
, new_unittest("is_close-real-${k1}$", test_is_close_real_${k1}$) &
, new_unittest("is_close-cmplx-${k1}$", test_is_close_cmplx_${k1}$) &
, new_unittest("all_close-real-${k1}$", test_all_close_real_${k1}$) &
, new_unittest("all_close-cmplx-${k1}$", test_all_close_cmplx_${k1}$) &
#:endfor
!> Tests for `diff`
#:for k1 in REAL_KINDS
, new_unittest("diff-real-${k1}$", test_diff_real_${k1}$) &
#:endfor
#:for k1 in INT_KINDS
, new_unittest("diff-int-${k1}$", test_diff_int_${k1}$) &
#:endfor
!> Tests for `arange`
#:for k1 in REAL_KINDS
, new_unittest("arange-real-${k1}$", test_arange_real_${k1}$) &
#:endfor
#:for k1 in INT_KINDS
, new_unittest("arange-int-${k1}$", test_arange_int_${k1}$) &
#:endfor
]
end subroutine collect_stdlib_math
subroutine test_clip_int8(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! clip function
! testing format: check(clip(x, xmin, xmax) == correct answer)
! valid case: xmin is not greater than xmax
! invalid case: xmin is greater than xmax
! type: integer(int8), kind: int8
! valid test case
call check(error, clip(2_int8, -2_int8, 5_int8), 2_int8)
if (allocated(error)) return
call check(error, clip(127_int8, -127_int8, 0_int8), 0_int8)
if (allocated(error)) return
end subroutine test_clip_int8
subroutine test_clip_int8_bounds(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! invalid test case
call check(error, clip(2_int8, 5_int8, -2_int8), 5_int8)
if (allocated(error)) return
call check(error, clip(127_int8, 0_int8, -127_int8), 0_int8)
if (allocated(error)) return
end subroutine test_clip_int8_bounds
subroutine test_clip_int16(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! type: integer(int16), kind: int16
! valid test case
call check(error, clip(2_int16, -2_int16, 5_int16), 2_int16)
if (allocated(error)) return
call check(error, clip(32767_int16, -32767_int16, 0_int16), 0_int16)
if (allocated(error)) return
end subroutine test_clip_int16
subroutine test_clip_int16_bounds(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! invalid test case
call check(error, clip(2_int16, 5_int16, -2_int16), 5_int16)
if (allocated(error)) return
call check(error, clip(32767_int16, 0_int16, -32767_int16), 0_int16)
if (allocated(error)) return
end subroutine test_clip_int16_bounds
subroutine test_clip_int32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! type: integer(int32), kind: int32
! valid test case
call check(error, clip(2_int32, -2_int32, 5_int32), 2_int32)
if (allocated(error)) return
call check(error, clip(-2147483647_int32, 0_int32, 2147483647_int32), 0_int32)
if (allocated(error)) return
end subroutine test_clip_int32
subroutine test_clip_int32_bounds(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! invalid test case
call check(error, clip(2_int32, 5_int32, -2_int32), 5_int32)
if (allocated(error)) return
call check(error, clip(-2147483647_int32, 2147483647_int32, 0_int32), 2147483647_int32)
if (allocated(error)) return
end subroutine test_clip_int32_bounds
subroutine test_clip_int64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! type: integer(int64), kind: int64
! valid test case
call check(error, clip(2_int64, -2_int64, 5_int64), 2_int64)
if (allocated(error)) return
call check(error, clip(-922337203_int64, -10_int64, 25_int64), -10_int64)
if (allocated(error)) return
end subroutine test_clip_int64
subroutine test_clip_int64_bounds(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! invalid test case
call check(error, clip(2_int64, 5_int64, -2_int64), 5_int64)
if (allocated(error)) return
call check(error, clip(-922337203_int64, 25_int64, -10_int64), 25_int64)
if (allocated(error)) return
end subroutine test_clip_int64_bounds
subroutine test_clip_rsp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! type: real(sp), kind: sp
! valid test case
call check(error, clip(3.025_sp, -5.77_sp, 3.025_sp), 3.025_sp)
if (allocated(error)) return
call check(error, clip(0.0_sp, -1578.025_sp, -59.68_sp), -59.68_sp)
if (allocated(error)) return
end subroutine test_clip_rsp
subroutine test_clip_rsp_bounds(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! invalid test case
call check(error, clip(3.025_sp, 3.025_sp, -5.77_sp), 3.025_sp)
if (allocated(error)) return
call check(error, clip(0.0_sp, -59.68_sp, -1578.025_sp), -59.68_sp)
if (allocated(error)) return
end subroutine test_clip_rsp_bounds
subroutine test_clip_rdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! type: real(dp), kind: dp
! valid test case
call check(error, clip(3.025_dp, -5.77_dp, 3.025_dp), 3.025_dp)
if (allocated(error)) return
call check(error, clip(-7.0_dp, 0.059668_dp, 1.00268_dp), 0.059668_dp)
if (allocated(error)) return
end subroutine test_clip_rdp
subroutine test_clip_rdp_bounds(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! invalid test case
call check(error, clip(3.025_dp, 3.025_dp, -5.77_dp), 3.025_dp)
if (allocated(error)) return
call check(error, clip(-7.0_dp, 1.00268_dp, 0.059668_dp), 1.00268_dp)
if (allocated(error)) return
end subroutine test_clip_rdp_bounds
subroutine test_clip_rqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
! type: real(qp), kind: qp
! valid test case
call check(error, clip(3.025_qp, -5.77_qp, 3.025_qp), 3.025_qp)
if (allocated(error)) return
call check(error, clip(-55891546.2_qp, -8958133457.23_qp, -689712245.23_qp), -689712245.23_qp)
if (allocated(error)) return
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_clip_rqp
subroutine test_clip_rqp_bounds(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
! invalid test case
call check(error, clip(3.025_qp, 3.025_qp, -5.77_qp), 3.025_qp)
if (allocated(error)) return
call check(error, clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp), -689712245.23_qp)
if (allocated(error)) return
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_clip_rqp_bounds
#:for k1, t1 in INT_KINDS_TYPES + REAL_KINDS_TYPES
subroutine test_swap_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
${t1}$ :: x(3), y(3)
x = [${t1}$ :: 1, 2, 3]
y = [${t1}$ :: 4, 5, 6]
call swap(x,y)
call check(error, all( x == [${t1}$ :: 4, 5, 6] ) )
if (allocated(error)) return
call check(error, all( y == [${t1}$ :: 1, 2, 3] ) )
if (allocated(error)) return
! check self swap
call swap(x,x)
call check(error, all( x == [${t1}$ :: 4, 5, 6] ) )
if (allocated(error)) return
end subroutine test_swap_${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
subroutine test_swap_c${k1}$(error)
type(error_type), allocatable, intent(out) :: error
${t1}$ :: x(3), y(3)
x = cmplx( [1, 2, 3] , [4, 5, 6] )
y = cmplx( [4, 5, 6] , [1, 2, 3] )
call swap(x,y)
call check(error, all( x == cmplx( [4, 5, 6] , [1, 2, 3] ) ) )
if (allocated(error)) return
call check(error, all( y == cmplx( [1, 2, 3] , [4, 5, 6] ) ) )
if (allocated(error)) return
! check self swap
call swap(x,x)
call check(error, all( x == cmplx( [4, 5, 6] , [1, 2, 3] ) ) )
if (allocated(error)) return
end subroutine test_swap_c${k1}$
#:endfor
subroutine test_swap_str(error)
type(error_type), allocatable, intent(out) :: error
block
character(5) :: x(2), y(2)
x = ['abcde','fghij']
y = ['fghij','abcde']
call swap(x,y)
call check(error, all( x == ['fghij','abcde'] ) )
if (allocated(error)) return
call check(error, all( y == ['abcde','fghij'] ) )
if (allocated(error)) return
! check self swap
call swap(x,x)
call check(error, all( x == ['fghij','abcde'] ) )
if (allocated(error)) return
end block
block
character(4) :: x
character(6) :: y
x = 'abcd'
y = 'efghij'
call swap(x,y)
call check(error, x == 'efgh' )
if (allocated(error)) return
call check(error, y(1:6) == 'abcd ' )
if (allocated(error)) return
x = 'abcd'
y = 'efghij'
call swap(x,y(1:4))
call check(error, x == 'efgh' )
if (allocated(error)) return
call check(error, y == 'abcdij' )
if (allocated(error)) return
end block
end subroutine test_swap_str
subroutine test_swap_stt(error)
use stdlib_string_type
type(error_type), allocatable, intent(out) :: error
type(string_type) :: x(2), y(2)
x = ['abcde','fghij']
y = ['fghij','abcde']
call swap(x,y)
call check(error, all( x == ['fghij','abcde'] ) )
if (allocated(error)) return
call check(error, all( y == ['abcde','fghij'] ) )
if (allocated(error)) return
! check self swap
call swap(x,x)
call check(error, all( x == ['fghij','abcde'] ) )
if (allocated(error)) return
end subroutine test_swap_stt
#if STDLIB_BITSETS
subroutine test_swap_bitset_64(error)
use stdlib_bitsets
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: x, y, u, v
x = [.true.,.false.,.true.,.false.]
u = x
y = [.false.,.true.,.false.,.true.]
v = y
call swap(x,y)
call check(error, x == v )
if (allocated(error)) return
call check(error, y == u )
if (allocated(error)) return
! check self swap
call swap(x,x)
call check(error, x == v )
if (allocated(error)) return
end subroutine test_swap_bitset_64
subroutine test_swap_bitset_large(error)
use stdlib_bitsets
type(error_type), allocatable, intent(out) :: error
type(bitset_large) :: x, y, u, v
x = [.true.,.false.,.true.,.false.]
u = x
y = [.false.,.true.,.false.,.true.]
v = y
call swap(x,y)
call check(error, x == v )
if (allocated(error)) return
call check(error, y == u )
if (allocated(error)) return
! check self swap
call swap(x,x)
call check(error, x == v )
if (allocated(error)) return
end subroutine test_swap_bitset_large
#endif
#:for k1 in CMPLX_KINDS
subroutine test_arg_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$), parameter :: tol = sqrt(epsilon(1.0_${k1}$))
real(${k1}$), allocatable :: theta(:)
#! For scalar
call check(error, abs(arg(2*exp((0.0_${k1}$, 0.5_${k1}$))) - 0.5_${k1}$) < tol, &
"test_nonzero_scalar")
if (allocated(error)) return
call check(error, abs(arg((0.0_${k1}$, 0.0_${k1}$)) - 0.0_${k1}$) < tol, &
"test_zero_scalar")
if (allocated(error)) return
#! and for array (180.0° see scalar version)
theta = arange(-179.0_${k1}$, 179.0_${k1}$, 3.58_${k1}$)
call check(error, all(abs(arg(exp(cmplx(0.0_${k1}$, theta/180*PI_${k1}$, ${k1}$))) - theta/180*PI_${k1}$) < tol), &
"test_array")
end subroutine test_arg_${k1}$
subroutine test_argd_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$), parameter :: tol = sqrt(epsilon(1.0_${k1}$))
real(${k1}$), allocatable :: theta(:)
#! For scalar
call check(error, abs(argd((-1.0_${k1}$, 0.0_${k1}$)) - 180.0_${k1}$) < tol, &
"test_nonzero_scalar")
if (allocated(error)) return
call check(error, abs(argd((0.0_${k1}$, 0.0_${k1}$)) - 0.0_${k1}$) < tol, &
"test_zero_scalar")
if (allocated(error)) return
#! and for array (180.0° see scalar version)
theta = arange(-179.0_${k1}$, 179.0_${k1}$, 3.58_${k1}$)
call check(error, all(abs(argd(exp(cmplx(0.0_${k1}$, theta/180*PI_${k1}$, ${k1}$))) - theta) < tol), &
"test_array")
end subroutine test_argd_${k1}$
subroutine test_argpi_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$), parameter :: tol = sqrt(epsilon(1.0_${k1}$))
real(${k1}$), allocatable :: theta(:)
#! For scalar
call check(error, abs(argpi((-1.0_${k1}$, 0.0_${k1}$)) - 1.0_${k1}$) < tol, &
"test_nonzero_scalar")
if (allocated(error)) return
call check(error, abs(argpi((0.0_${k1}$, 0.0_${k1}$)) - 0.0_${k1}$) < tol, &
"test_zero_scalar")
if (allocated(error)) return
#! and for array (180.0° see scalar version)
theta = arange(-179.0_${k1}$, 179.0_${k1}$, 3.58_${k1}$)
call check(error, all(abs(argpi(exp(cmplx(0.0_${k1}$, theta/180*PI_${k1}$, ${k1}$))) - theta/180) < tol), &
"test_array")
end subroutine test_argpi_${k1}$
#:endfor
#:for k1 in REAL_KINDS
subroutine test_deg2rad_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$), parameter :: tol = sqrt(epsilon(1.0_${k1}$))
call check(error, PI_${k1}$, deg2rad(180.0_${k1}$), thr=tol)
if (allocated(error)) return
end subroutine test_deg2rad_${k1}$
subroutine test_rad2deg_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$), parameter :: tol = sqrt(epsilon(1.0_${k1}$))
call check(error, 180.0_${k1}$, rad2deg(PI_${k1}$), thr=tol)
if (allocated(error)) return
end subroutine test_rad2deg_${k1}$
#:endfor
#:for k1 in REAL_KINDS
subroutine test_is_close_real_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$) :: x, NAN
x = -3; NAN = sqrt(x)
call check(error, is_close(2.5_${k1}$, 2.5_${k1}$), .true.)
if (allocated(error)) return
call check(error, is_close(0.0_${k1}$, -0.0_${k1}$), .true.)
if (allocated(error)) return
call check(error, is_close(2.5_${k1}$, 1.2_${k1}$), .false.)
if (allocated(error)) return
call check(error, is_close(NAN, NAN), .false.)
if (allocated(error)) return
call check(error, is_close(NAN, 0.0_${k1}$), .false.)
if (allocated(error)) return
call check(error, is_close(NAN, NAN, equal_nan=.true.), .true.)
end subroutine test_is_close_real_${k1}$
subroutine test_is_close_cmplx_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$) :: x, NAN
x = -3; NAN = sqrt(x)
call check(error, is_close((2.5_${k1}$, 1.5_${k1}$), (2.5_${k1}$, 1.5_${k1}$)), .true.)
if (allocated(error)) return
call check(error, is_close((2.5_${k1}$, 1.2_${k1}$), (2.5_${k1}$, 1.5_${k1}$)), .false.)
if (allocated(error)) return
call check(error, is_close(cmplx(NAN, NAN, ${k1}$), cmplx(NAN, NAN, ${k1}$)), .false.)
if (allocated(error)) return
call check(error, is_close(cmplx(NAN, NAN, ${k1}$), cmplx(NAN, 0.0_${k1}$, ${k1}$)), .false.)
if (allocated(error)) return
call check(error, is_close(cmplx(NAN, NAN, ${k1}$), cmplx(NAN, NAN, ${k1}$), equal_nan=.true.), .true.)
if (allocated(error)) return
call check(error, is_close(cmplx(NAN, 1.2_${k1}$, ${k1}$), cmplx(NAN, 1.2_${k1}$, ${k1}$), equal_nan=.true.), .true.)
end subroutine test_is_close_cmplx_${k1}$
subroutine test_all_close_real_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$) :: x(2, 2), eps, NAN
x = 1; eps = -3; NAN = sqrt(eps)
eps = sqrt(epsilon(1.0_${k1}$))
call check(error, all_close(x, x), .true.)
if (allocated(error)) return
call check(error, all_close(x + x*eps + 1.0e-6, x), .false.)
if (allocated(error)) return
call check(error, all_close(x + NAN, x), .false.)
if (allocated(error)) return
call check(error, all_close(x + NAN, x, equal_nan=.true.), .false.)
if (allocated(error)) return
call check(error, all_close(x + NAN, x + NAN), .false.)
if (allocated(error)) return
call check(error, all_close(x + NAN, x + NAN, equal_nan=.true.), .true.)
end subroutine test_all_close_real_${k1}$
subroutine test_all_close_cmplx_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
real(${k1}$) :: eps, NAN
complex(${k1}$) :: x(2, 2)
x = (1, 1); eps = -3; NAN = sqrt(eps)
eps = sqrt(epsilon(1.0_${k1}$))
call check(error, all_close(x, x), .true.)
if (allocated(error)) return
call check(error, all_close(x + x*eps + 1.0e-6, x), .false.)
if (allocated(error)) return
call check(error, all_close(x + cmplx(NAN, NAN, ${k1}$), x), .false.)
if (allocated(error)) return
call check(error, all_close(x + cmplx(NAN, NAN, ${k1}$), x, equal_nan=.true.), .false.)
if (allocated(error)) return
call check(error, all_close(x + cmplx(NAN, NAN, ${k1}$), x + cmplx(NAN, NAN, ${k1}$), equal_nan=.true.), .true.)
if (allocated(error)) return
call check(error, all_close(x + cmplx(NAN, NAN, ${k1}$), x + cmplx(NAN, NAN, ${k1}$)), .false.)
end subroutine test_all_close_cmplx_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
subroutine test_diff_real_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
${t1}$ :: x(6) = [${t1}$ :: 0, 5, 15, 30, 50, 75]
${t1}$ :: A(1, 3) = reshape([${t1}$ :: 1, 3, 5], [1, 3])
${t1}$ :: B(2) = [${t1}$ :: 1, 2]
!> rank-1 diff
call check(error, all_close(diff(x), [${t1}$ :: 5, 10, 15, 20, 25]), &
"diff() in test_diff_real_${k1}$ failed")
if (allocated(error)) return
call check(error, all_close(diff(x, n=0), x), &
"diff(, n=0) in test_diff_real_${k1}$ failed")
if (allocated(error)) return
call check(error, all_close(diff(x, n=2), [${t1}$ :: 5, 5, 5, 5]), &
"diff(, n=2) in test_diff_real_${k1}$ failed")
if (allocated(error)) return
call check(error, all_close(diff(x, prepend=[${t1}$ :: 1]), [${t1}$ :: -1, 5, 10, 15, 20, 25]), &
"diff(, prepend=[${t1}$ :: 1]) in test_diff_real_${k1}$ failed")
if (allocated(error)) return
call check(error, all_close(diff(x, append=[${t1}$ :: 1]), [${t1}$ :: 5, 10, 15, 20, 25, -74]), &
"diff(, append=[${t1}$ :: 1]) in test_diff_real_${k1}$ failed")
if (allocated(error)) return
!> rank-2 diff
call check(error, all_close(diff(reshape(A, [3,1]), n=1, dim=1), reshape([${t1}$ :: 2, 2], [2, 1])), &
"diff(, n=1, dim=1) in test_diff_real_${k1}$ failed")
if (allocated(error)) return
call check(error, all_close(diff(A, n=1, dim=2), reshape([${t1}$ :: 2, 2], [1, 2])), &
"diff(, n=1, dim=2) in test_diff_real_${k1}$ failed")
if (allocated(error)) return
call check(error, all_close(diff(A, n=1, dim=2, prepend=reshape([${t1}$ :: 1], [1, 1]), &
append=reshape([${t1}$ :: 2], [1, 1])), reshape([${t1}$ :: 0, 2, 2, -3], [1, 4])), &
"diff(, n=1, dim=2, prepend=reshape([${t1}$ :: 1], [1, 1]), &
&append=reshape([${t1}$ :: 2], [1, 1])) in test_diff_real_${k1}$ failed")
if (allocated(error)) return
!> size(B, dim) <= n
call check(error, size(diff(B, 2)), 0, "size(diff(B, 2)) in test_diff_real_${k1}$ failed")
if (allocated(error)) return
call check(error, size(diff(B, 3)), 0, "size(diff(B, 3)) in test_diff_real_${k1}$ failed")
end subroutine test_diff_real_${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
subroutine test_diff_int_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
${t1}$ :: x(6) = [${t1}$ :: 0, 5, 15, 30, 50, 75]
${t1}$ :: A(1, 3) = reshape([${t1}$ :: 1, 3, 5], [1, 3])
${t1}$ :: B(2) = [${t1}$ :: 1, 2]
!> rank-1 diff
call check(error, all(diff(x) == [${t1}$ :: 5, 10, 15, 20, 25]), &
"diff() in test_diff_int_${k1}$ failed")
if (allocated(error)) return
call check(error, all(diff(x, n=0) == x), &
"diff(, n=0) in test_diff_int_${k1}$ failed")
if (allocated(error)) return
call check(error, all(diff(x, n=2) == [${t1}$ :: 5, 5, 5, 5]), &
"diff(, n=2) in test_diff_int_${k1}$ failed")
if (allocated(error)) return
call check(error, all(diff(x, prepend=[${t1}$ :: 1]) == [${t1}$ :: -1, 5, 10, 15, 20, 25]), &
"diff(, prepend=[${t1}$ :: 1]) in test_diff_int_${k1}$ failed")
if (allocated(error)) return
call check(error, all(diff(x, append=[${t1}$ :: 1]) == [${t1}$ :: 5, 10, 15, 20, 25, -74]), &
"diff(, append=[${t1}$ :: 1]) in test_diff_int_${k1}$ failed")
if (allocated(error)) return
!> rank-2 diff
call check(error, all(diff(reshape(A, [3,1]), n=1, dim=1) == reshape([${t1}$ :: 2, 2], [2, 1])), &
"diff(, n=1, dim=1) in test_diff_int_${k1}$ failed")
if (allocated(error)) return
call check(error, all(diff(A, n=1, dim=2) == reshape([${t1}$ :: 2, 2], [1, 2])), &
"diff(, n=1, dim=2) in test_diff_int_${k1}$ failed")
if (allocated(error)) return
call check(error, all(diff(A, n=1, dim=2, prepend=reshape([${t1}$ :: 1], [1, 1]), &
append=reshape([${t1}$ :: 2], [1, 1])) == reshape([${t1}$ :: 0, 2, 2, -3], [1, 4])), &
"diff(, n=1, dim=2, prepend=reshape([${t1}$ :: 1], [1, 1]), &
&append=reshape([${t1}$ :: 2], [1, 1])) in test_diff_int_${k1}$ failed")
if (allocated(error)) return
!> size(B, dim) <= n
call check(error, size(diff(B, 2)), 0, "size(diff(B, 2)) in test_diff_int_${k1}$ failed")
if (allocated(error)) return
call check(error, size(diff(B, 3)), 0, "size(diff(B, 3)) in test_diff_int_${k1}$ failed")
end subroutine test_diff_int_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
subroutine test_arange_real_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
! Normal
call check(error, all_close(arange(3.0_${k1}$), [1.0_${k1}$, 2.0_${k1}$, 3.0_${k1}$]), &
"all(arange(3.0_${k1}$), [1.0_${k1}$,2.0_${k1}$,3.0_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all_close(arange(-1.0_${k1}$), [1.0_${k1}$, 0.0_${k1}$, -1.0_${k1}$]), &
"all_close(arange(-1.0_${k1}$), [1.0_${k1}$,0.0_${k1}$,-1.0_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all_close(arange(0.0_${k1}$, 2.0_${k1}$), [0.0_${k1}$, 1.0_${k1}$, 2.0_${k1}$]), &
"all_close(arange(0.0_${k1}$,2.0_${k1}$), [0.0_${k1}$,1.0_${k1}$,2.0_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all_close(arange(1.0_${k1}$, -1.0_${k1}$), [1.0_${k1}$, 0.0_${k1}$, -1.0_${k1}$]), &
"all_close(arange(1.0_${k1}$,-1.0_${k1}$), [1.0_${k1}$,0.0_${k1}$,-1.0_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all_close(arange(1.0_${k1}$, 1.0_${k1}$), [1.0_${k1}$]), &
"all_close(arange(1.0_${k1}$,1.0_${k1}$), [1.0_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all_close(arange(0.0_${k1}$, 2.0_${k1}$, 2.0_${k1}$), [0.0_${k1}$, 2.0_${k1}$]), &
"all_close(arange(0.0_${k1}$,2.0_${k1}$,2.0_${k1}$), [0.0_${k1}$,2.0_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all_close(arange(1.0_${k1}$, -1.0_${k1}$, 2.0_${k1}$), [1.0_${k1}$, -1.0_${k1}$]), &
"all_close(arange(1.0_${k1}$,-1.0_${k1}$,2.0_${k1}$), [1.0_${k1}$,-1.0_${k1}$]) failed.")
if (allocated(error)) return
! Not recommended
call check(error, all_close(arange(0.0_${k1}$, 2.0_${k1}$, -2.0_${k1}$), [0.0_${k1}$, 2.0_${k1}$]), &
"all_close(arange(0.0_${k1}$,2.0_${k1}$,-2.0_${k1}$), [0.0_${k1}$,2.0_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all_close(arange(1.0_${k1}$, -1.0_${k1}$, -2.0_${k1}$), [1.0_${k1}$, -1.0_${k1}$]), &
"all_close(arange(1.0_${k1}$,-1.0_${k1}$,-2.0_${k1}$), [1.0_${k1}$,-1.0_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all_close(arange(0.0_${k1}$, 2.0_${k1}$, 0.0_${k1}$), [0.0_${k1}$,1.0_${k1}$,2.0_${k1}$]), &
"all_close(arange(0.0_${k1}$, 2.0_${k1}$, 0.0_${k1}$), [0.0_${k1}$,1.0_${k1}$,2.0_${k1}$]) failed.")
end subroutine test_arange_real_${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
subroutine test_arange_int_${k1}$(error)
type(error_type), allocatable, intent(out) :: error
! Normal
call check(error, all(arange(3_${k1}$) == [1_${k1}$, 2_${k1}$, 3_${k1}$]), &
"all(arange(3_${k1}$) == [1_${k1}$,2_${k1}$,3_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all(arange(-1_${k1}$) == [1_${k1}$, 0_${k1}$, -1_${k1}$]), &
"all(arange(-1_${k1}$) == [1_${k1}$,0_${k1}$,-1_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all(arange(0_${k1}$, 2_${k1}$) == [0_${k1}$, 1_${k1}$, 2_${k1}$]), &
"all(arange(0_${k1}$,2_${k1}$) == [0_${k1}$,1_${k1}$,2_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all(arange(1_${k1}$, -1_${k1}$) == [1_${k1}$, 0_${k1}$, -1_${k1}$]), &
"all(arange(1_${k1}$,-1_${k1}$) == [1_${k1}$,0_${k1}$,-1_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all(arange(1_${k1}$, 1_${k1}$) == [1_${k1}$]), &
"all(arange(1_${k1}$,1_${k1}$) == [1_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all(arange(0_${k1}$, 2_${k1}$, 2_${k1}$) == [0_${k1}$, 2_${k1}$]), &
"all(arange(0_${k1}$,2_${k1}$,2_${k1}$) == [0_${k1}$,2_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all(arange(1_${k1}$, -1_${k1}$, 2_${k1}$) == [1_${k1}$, -1_${k1}$]), &
"all(arange(1_${k1}$,-1_${k1}$,2_${k1}$) == [1_${k1}$,-1_${k1}$]) failed.")
if (allocated(error)) return
! Not recommended
call check(error, all(arange(0_${k1}$, 2_${k1}$, -2_${k1}$) == [0_${k1}$, 2_${k1}$]), &
"all(arange(0_${k1}$,2_${k1}$,2_${k1}$) == [0_${k1}$,2_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all(arange(1_${k1}$, -1_${k1}$, -2_${k1}$) == [1_${k1}$, -1_${k1}$]), &
"all(arange(1_${k1}$,-1_${k1}$,2_${k1}$) == [1_${k1}$,-1_${k1}$]) failed.")
if (allocated(error)) return
call check(error, all(arange(0_${k1}$, 2_${k1}$, 0_${k1}$) == [0_${k1}$, 1_${k1}$, 2_${k1}$]), &
"all(arange(0_${k1}$,2_${k1}$,0_${k1}$) == [0_${k1}$,1_${k1}$,2_${k1}$]) failed.")
end subroutine test_arange_int_${k1}$
#:endfor
end module test_stdlib_math
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_stdlib_math, only : collect_stdlib_math
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("stdlib-math", collect_stdlib_math) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/math/test_meshgrid.fypp 0000664 0001750 0001750 00000010166 15135654166 023643 0 ustar alastair alastair ! SPDX-Identifier: MIT
#:include "common.fypp"
#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES
#:set RANKS = range(1, MAXRANK + 1)
#:set INDEXINGS = ["default", "xy", "ij"]
#:def OPTIONAL_PART_IN_SIGNATURE(indexing)
#:if indexing in ("xy", "ij")
${f', stdlib_meshgrid_{indexing}'}$
#:endif
#:enddef
module test_meshgrid
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_math, only: meshgrid, stdlib_meshgrid_ij, stdlib_meshgrid_xy
use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
implicit none
public :: collect_meshgrid
contains
!> Collect all exported unit tests
subroutine collect_meshgrid(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
#:for k1, t1 in IR_KINDS_TYPES
#:for rank in RANKS
#:for INDEXING in INDEXINGS
#: set RName = rname(f"meshgrid_{INDEXING}", rank, t1, k1)
new_unittest("${RName}$", test_${RName}$), &
#:endfor
#:endfor
#:endfor
new_unittest("dummy", test_dummy) &
]
end subroutine collect_meshgrid
#:for k1, t1 in IR_KINDS_TYPES
#:for rank in RANKS
#:for INDEXING in INDEXINGS
#:if rank == 1
#:set INDICES = [1]
#:else
#:if INDEXING in ("default", "xy")
#:set INDICES = [2, 1] + [j for j in range(3, rank + 1)]
#:elif INDEXING == "ij"
#:set INDICES = [1, 2] + [j for j in range(3, rank + 1)]
#:endif
#:endif
#:set RName = rname(f"meshgrid_{INDEXING}", rank, t1, k1)
#:set GRIDSHAPE = "".join("length," for j in range(rank)).removesuffix(",")
subroutine test_${RName}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: length = 3
${t1}$ :: ${"".join(f"x{j}(length)," for j in range(1, rank + 1)).removesuffix(",")}$
${t1}$ :: ${"".join(f"xm{j}({GRIDSHAPE})," for j in range(1, rank + 1)).removesuffix(",")}$
${t1}$ :: ${"".join(f"xm{j}_exact({GRIDSHAPE})," for j in range(1, rank + 1)).removesuffix(",")}$
integer :: i
integer :: ${"".join(f"i{j}," for j in range(1, rank + 1)).removesuffix(",")}$
${t1}$, parameter :: ZERO = 0
! valid test case
#:for index in range(1, rank + 1)
x${index}$ = [(i, i = length * ${index - 1}$ + 1, length * ${index}$)]
#:endfor
#:for j in range(1, rank + 1)
xm${j}$_exact = reshape( &
[${"".join("(" for dummy in range(rank)) + f"x{j}(i{j})" + "".join(f", i{index} = 1, size(x{index}))" for index in INDICES)}$], &
shape=[${GRIDSHAPE}$] &
)
#:endfor
call meshgrid( &
${"".join(f"x{j}," for j in range(1, rank + 1))}$ &
${"".join(f"xm{j}," for j in range(1, rank + 1)).removesuffix(",")}$ &
${OPTIONAL_PART_IN_SIGNATURE(INDEXING)}$ )
#:for j in range(1, rank + 1)
call check(error, maxval(abs(xm${j}$ - xm${j}$_exact)), ZERO)
if (allocated(error)) return
#:endfor
end subroutine test_${RName}$
#:endfor
#:endfor
#:endfor
subroutine test_dummy(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
end subroutine
end module test_meshgrid
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_meshgrid, only : collect_meshgrid
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("meshgrid", collect_meshgrid) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/CMakeLists.txt 0000664 0001750 0001750 00000003464 15135654166 021714 0 ustar alastair alastair if (NOT TARGET "test-drive::test-drive")
find_package("test-drive" REQUIRED)
endif()
if(WIN32)
if(CMAKE_Fortran_COMPILER_ID MATCHES "^Intel")
add_link_options(/Qoption,link,/STACK:8388608)
elseif(CMAKE_Fortran_COMPILER_ID STREQUAL GNU)
add_link_options(-Wl,--stack,8388608)
endif()
endif()
macro(ADDTEST name)
add_executable(test_${name} test_${name}.f90)
target_link_libraries(test_${name} "${PROJECT_NAME}" "test-drive::test-drive")
add_test(NAME ${name}
COMMAND $ ${CMAKE_CURRENT_BINARY_DIR}
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
endmacro(ADDTEST)
macro(ADDTESTPP name)
add_executable(test_${name} test_${name}.F90)
target_link_libraries(test_${name} "${PROJECT_NAME}" "test-drive::test-drive")
add_test(NAME ${name}
COMMAND $ ${CMAKE_CURRENT_BINARY_DIR}
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
endmacro(ADDTESTPP)
add_subdirectory(array)
add_subdirectory(ascii)
if (STDLIB_BITSETS)
add_subdirectory(bitsets)
endif()
add_subdirectory(constants)
add_subdirectory(hash_functions)
add_subdirectory(hash_functions_perf)
if (STDLIB_HASHMAPS)
add_subdirectory(hashmaps)
endif()
add_subdirectory(intrinsics)
if (STDLIB_IO)
add_subdirectory(io)
endif()
add_subdirectory(linalg)
if (STDLIB_LOGGER)
add_subdirectory(logger)
endif()
add_subdirectory(optval)
add_subdirectory(selection)
add_subdirectory(sorting)
add_subdirectory(specialfunctions)
if (STDLIB_STATS)
add_subdirectory(stats)
endif()
add_subdirectory(string)
if (STDLIB_SYSTEM)
add_subdirectory(system)
endif()
if (STDLIB_QUADRATURE)
add_subdirectory(quadrature)
endif()
add_subdirectory(math)
if (STDLIB_STRINGLIST)
add_subdirectory(stringlist)
endif()
if (STDLIB_ANSI)
add_subdirectory(terminal)
endif()
fortran-lang-stdlib-0ede301/test/constants/ 0000775 0001750 0001750 00000000000 15135654166 021161 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/constants/test_constants.f90 0000664 0001750 0001750 00000024412 15135654166 024557 0 ustar alastair alastair module test_constants
!! Test constant values only for double precision.
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_kinds, only : dp, int32
use stdlib_codata, only: YEAR, &
ALPHA_PARTICLE_ELECTRON_MASS_RATIO, &
ALPHA_PARTICLE_MASS, &
ATOMIC_MASS_CONSTANT, &
AVOGADRO_CONSTANT, &
BOLTZMANN_CONSTANT, &
ELECTRON_VOLT, &
ELEMENTARY_CHARGE, &
FARADAY_CONSTANT, &
MOLAR_MASS_CONSTANT,&
MOLAR_VOLUME_OF_IDEAL_GAS_273_15_K_101_325_KPA, &
PLANCK_CONSTANT,&
SPEED_OF_LIGHT_IN_VACUUM,&
STANDARD_ACCELERATION_OF_GRAVITY
implicit none
private
public :: collect_constants
contains
!> Collect all exported unit tests
subroutine collect_constants(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [new_unittest("YEAR", test_year), &
new_unittest("ALPHA_PARTICLE_ELECTRON_MASS_RATIO", test_ALPHA_PARTICLE_ELECTRON_MASS_RATIO),&
new_unittest("ALPHA_PARTICLE_MASS", test_ALPHA_PARTICLE_MASS),&
new_unittest("ATOMIC_MASS_CONSTANT", test_ATOMIC_MASS_CONSTANT),&
new_unittest("AVOGADRO_CONSTANT", test_AVOGADRO_CONSTANT),&
new_unittest("BOLTZMANN_CONSTANT", test_BOLTZMANN_CONSTANT),&
new_unittest("ELECTRON_VOLT", test_ELECTRON_VOLT),&
new_unittest("ELEMENTARY_CHARGE", test_ELEMENTARY_CHARGE),&
new_unittest("FARADAY_CONSTANT", test_FARADAY_CONSTANT),&
new_unittest("MOLAR_MASS_CONSTANT", test_MOLAR_MASS_CONSTANT),&
new_unittest("MOLAR_VOLUME_OF_IDEAL_GAS__273_15K__101_325_KPA", test_MOLAR_VOLUME_NTP),&
new_unittest("PLANCK_CONSTANT", test_PLANCK_CONSTANT),&
new_unittest("SPEED_OF_LIGHT_IN_VACUUM", test_SPEED_OF_LIGHT),&
new_unittest("STANDARD_ACCELERATION_OF_GRAVITY", test_STANDARD_ACCELERATION_OF_GRAVITY),&
new_unittest("U_ALPHA_PARTICLE_ELECTRON_MASS_RATIO", test_U_ALPHA_PARTICLE_ELECTRON_MASS_RATIO),&
new_unittest("U_ALPHA_PARTICLE_MASS", test_U_ALPHA_PARTICLE_MASS),&
new_unittest("U_ATOMIC_MASS_CONSTANT", test_U_ATOMIC_MASS_CONSTANT),&
new_unittest("U_AVOGADRO_CONSTANT", test_U_AVOGADRO_CONSTANT),&
new_unittest("U_BOLTZMANN_CONSTANT", test_U_BOLTZMANN_CONSTANT),&
new_unittest("U_ELECTRON_VOLT", test_U_ELECTRON_VOLT),&
new_unittest("U_ELEMENTARY_CHARGE", test_U_ELEMENTARY_CHARGE),&
new_unittest("U_FARADAY_CONSTANT", test_U_FARADAY_CONSTANT),&
new_unittest("U_MOLAR_MASS_CONSTANT", test_U_MOLAR_MASS_CONSTANT),&
new_unittest("U_MOLAR_VOLUME_OF_IDEAL_GAS__273_15K__101_325_KPA", test_U_MOLAR_VOLUME_NTP),&
new_unittest("U_PLANCK_CONSTANT", test_U_PLANCK_CONSTANT),&
new_unittest("U_SPEED_OF_LIGHT_IN_VACUUM", test_U_SPEED_OF_LIGHT),&
new_unittest("U_STANDARD_ACCELERATION_OF_GRAVITY", test_U_STANDARD_ACCELERATION_OF_GRAVITY)]
end subroutine
subroutine test_year(error)
type(error_type), allocatable, intent(out) :: error
call check(error, YEAR, 2022)
if (allocated(error)) return
end subroutine
subroutine test_ALPHA_PARTICLE_ELECTRON_MASS_RATIO(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ALPHA_PARTICLE_ELECTRON_MASS_RATIO%to_real(1.0_dp), 7294.29954171_dp)
if (allocated(error)) return
end subroutine
subroutine test_ALPHA_PARTICLE_MASS(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ALPHA_PARTICLE_MASS%to_real(1.0_dp), 6.6446573450d-27)
if (allocated(error)) return
end subroutine
subroutine test_ATOMIC_MASS_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ATOMIC_MASS_CONSTANT%to_real(1.0_dp), 1.66053906892d-27)
if (allocated(error)) return
end subroutine
subroutine test_AVOGADRO_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, AVOGADRO_CONSTANT%to_real(1.0_dp), 6.02214076d23)
if (allocated(error)) return
end subroutine
subroutine test_BOLTZMANN_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, BOLTZMANN_CONSTANT%to_real(1.0_dp), 1.380649d-23)
if (allocated(error)) return
end subroutine
subroutine test_ELECTRON_VOLT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ELECTRON_VOLT%to_real(1.0_dp), 1.602176634d-19)
if (allocated(error)) return
end subroutine
subroutine test_ELEMENTARY_CHARGE(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ELEMENTARY_CHARGE%to_real(1.0_dp), 1.602176634d-19)
if (allocated(error)) return
end subroutine
subroutine test_FARADAY_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, FARADAY_CONSTANT%to_real(1.0_dp), 96485.33212d0)
if (allocated(error)) return
end subroutine
subroutine test_MOLAR_MASS_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, MOLAR_MASS_CONSTANT%to_real(1.0_dp), 1.00000000105d-3)
if (allocated(error)) return
end subroutine
subroutine test_MOLAR_VOLUME_NTP(error)
type(error_type), allocatable, intent(out) :: error
call check(error, MOLAR_VOLUME_OF_IDEAL_GAS_273_15_K_101_325_KPA%to_real(1.0_dp), 22.41396954d-3)
if (allocated(error)) return
end subroutine
subroutine test_PLANCK_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, PLANCK_CONSTANT%to_real(1.0_dp), 6.62607015d-34)
if (allocated(error)) return
end subroutine
subroutine test_SPEED_OF_LIGHT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, SPEED_OF_LIGHT_IN_VACUUM%to_real(1.0_dp), 299792458.0d0)
if (allocated(error)) return
end subroutine
subroutine test_STANDARD_ACCELERATION_OF_GRAVITY(error)
type(error_type), allocatable, intent(out) :: error
call check(error, STANDARD_ACCELERATION_OF_GRAVITY%to_real(1.0_dp), 9.80665d0)
if (allocated(error)) return
end subroutine
subroutine test_U_ALPHA_PARTICLE_ELECTRON_MASS_RATIO(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ALPHA_PARTICLE_ELECTRON_MASS_RATIO%to_real(1.0_dp, uncertainty=.true.), 0.00000017d0)
if (allocated(error)) return
end subroutine
subroutine test_U_ALPHA_PARTICLE_MASS(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ALPHA_PARTICLE_MASS%to_real(1.0_dp, uncertainty=.true.), 0.0000000021d-27)
if (allocated(error)) return
end subroutine
subroutine test_U_ATOMIC_MASS_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ATOMIC_MASS_CONSTANT%to_real(1.0_dp, uncertainty=.true.), 0.00000000052d-27)
if (allocated(error)) return
end subroutine
subroutine test_U_AVOGADRO_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, AVOGADRO_CONSTANT%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
subroutine test_U_BOLTZMANN_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, BOLTZMANN_CONSTANT%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
subroutine test_U_ELECTRON_VOLT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ELECTRON_VOLT%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
subroutine test_U_ELEMENTARY_CHARGE(error)
type(error_type), allocatable, intent(out) :: error
call check(error, ELEMENTARY_CHARGE%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
subroutine test_U_FARADAY_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, FARADAY_CONSTANT%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
subroutine test_U_MOLAR_MASS_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, MOLAR_MASS_CONSTANT%to_real(1.0_dp, uncertainty=.true.), 0.00000000031d-3)
if (allocated(error)) return
end subroutine
subroutine test_U_MOLAR_VOLUME_NTP(error)
type(error_type), allocatable, intent(out) :: error
call check(error, MOLAR_VOLUME_OF_IDEAL_GAS_273_15_K_101_325_KPA%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
subroutine test_U_PLANCK_CONSTANT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, PLANCK_CONSTANT%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
subroutine test_U_SPEED_OF_LIGHT(error)
type(error_type), allocatable, intent(out) :: error
call check(error, SPEED_OF_LIGHT_IN_VACUUM%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
subroutine test_U_STANDARD_ACCELERATION_OF_GRAVITY(error)
type(error_type), allocatable, intent(out) :: error
call check(error, STANDARD_ACCELERATION_OF_GRAVITY%to_real(1.0_dp, uncertainty=.true.), 0.0_dp)
if (allocated(error)) return
end subroutine
end module test_constants
program tester
use iso_fortran_env
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_constants, only : collect_constants
implicit none
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
integer :: stat, is
stat = 0
testsuites = [new_testsuite("constants", collect_constants)]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/constants/CMakeLists.txt 0000664 0001750 0001750 00000000023 15135654166 023714 0 ustar alastair alastair ADDTEST(constants)
fortran-lang-stdlib-0ede301/test/ascii/ 0000775 0001750 0001750 00000000000 15135654166 020235 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/ascii/CMakeLists.txt 0000664 0001750 0001750 00000000017 15135654166 022773 0 ustar alastair alastair ADDTEST(ascii)
fortran-lang-stdlib-0ede301/test/ascii/test_ascii.f90 0000664 0001750 0001750 00000102030 15135654166 022700 0 ustar alastair alastair module test_ascii
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_ascii, only: lowercase, uppercase, digits, &
octal_digits, fullhex_digits, hex_digits, lowerhex_digits, &
whitespace, letters, is_alphanum, is_alpha, is_lower, is_upper, &
is_digit, is_octal_digit, is_hex_digit, is_white, is_blank, &
is_control, is_punctuation, is_graphical, is_printable, is_ascii, &
to_lower, to_upper, to_title, to_sentence, reverse, LF, TAB, NUL, DEL
use stdlib_kinds, only : int8, int16, int32, int64, lk
implicit none
private
public :: collect_ascii
contains
!> Collect all exported unit tests
subroutine collect_ascii(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("is_alphanum_short", test_is_alphanum_short), &
new_unittest("is_alphanum_long", test_is_alphanum_long), &
new_unittest("is_alpha_short", test_is_alpha_short), &
new_unittest("is_alpha_long", test_is_alpha_long), &
new_unittest("is_lower_short", test_is_lower_short), &
new_unittest("is_lower_long", test_is_lower_long), &
new_unittest("is_upper_short", test_is_upper_short), &
new_unittest("is_upper_long", test_is_upper_long), &
new_unittest("is_digit_short", test_is_digit_short), &
new_unittest("is_digit_long", test_is_digit_long), &
new_unittest("is_octal_digit_short", test_is_octal_digit_short), &
new_unittest("is_octal_digit_long", test_is_octal_digit_long), &
new_unittest("is_hex_digit_short", test_is_hex_digit_short), &
new_unittest("is_hex_digit_long", test_is_hex_digit_long), &
new_unittest("is_white_short", test_is_white_short), &
new_unittest("is_white_long", test_is_white_long), &
new_unittest("is_blank_short", test_is_blank_short), &
new_unittest("is_blank_long", test_is_blank_long), &
new_unittest("is_control_short", test_is_control_short), &
new_unittest("is_control_long", test_is_control_long), &
new_unittest("is_punctuation_short", test_is_punctuation_short), &
new_unittest("is_punctuation_long", test_is_punctuation_long), &
new_unittest("is_graphical_short", test_is_graphical_short), &
new_unittest("is_graphical_long", test_is_graphical_long), &
new_unittest("is_printable_short", test_is_printable_short), &
new_unittest("is_printable_long", test_is_printable_long), &
new_unittest("is_ascii_short", test_is_ascii_short), &
new_unittest("is_ascii_long", test_is_ascii_long), &
new_unittest("to_lower_short", test_to_lower_short), &
new_unittest("to_lower_long", test_to_lower_long), &
new_unittest("to_upper_short", test_to_upper_short), &
new_unittest("to_upper_long", test_to_upper_long), &
new_unittest("ascii_table", test_ascii_table), &
new_unittest("to_upper_string", test_to_upper_string), &
new_unittest("to_lower_string", test_to_lower_string), &
new_unittest("to_title_string", test_to_title_string), &
new_unittest("to_sentence_string", test_to_sentence_string), &
new_unittest("reverse_string", test_reverse_string) &
]
end subroutine collect_ascii
subroutine test_is_alphanum_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_alphanum('A'))
if (allocated(error)) return
call check(error, is_alphanum('1'))
if (allocated(error)) return
call check(error, .not. is_alphanum('#'))
if (allocated(error)) return
! N.B.: does not return true for non-ASCII Unicode alphanumerics
call check(error, .not. is_alphanum('á'))
if (allocated(error)) return
end subroutine
subroutine test_is_alphanum_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
clist = digits//octal_digits//fullhex_digits//letters//lowercase//uppercase
do i = 1, len(clist)
call check(error, is_alphanum(clist(i:i)))
if (allocated(error)) return
end do
clist = whitespace
do i = 1, len(clist)
call check(error, .not. is_alphanum(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_alpha_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_alpha('A'))
if (allocated(error)) return
call check(error, .not. is_alpha('1'))
if (allocated(error)) return
call check(error, .not. is_alpha('#'))
if (allocated(error)) return
! N.B.: does not return true for non-ASCII Unicode alphabetic characters
call check(error, .not. is_alpha('á'))
if (allocated(error)) return
end subroutine
subroutine test_is_alpha_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
clist = letters//lowercase//uppercase
do i = 1, len(clist)
call check(error, is_alpha(clist(i:i)))
if (allocated(error)) return
end do
clist = digits//octal_digits//whitespace
do i = 1, len(clist)
call check(error, .not. is_alpha(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_lower_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_lower('a'))
if (allocated(error)) return
call check(error, .not. is_lower('A'))
if (allocated(error)) return
call check(error, .not. is_lower('#'))
if (allocated(error)) return
! N.B.: does not return true for non-ASCII Unicode lowercase letters
call check(error, .not. is_lower('á'))
if (allocated(error)) return
call check(error, .not. is_lower('Á'))
if (allocated(error)) return
end subroutine
subroutine test_is_lower_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
do i = 1, len(lowercase)
call check(error, is_lower(lowercase(i:i)))
if (allocated(error)) return
end do
clist = digits//uppercase//whitespace
do i = 1, len(clist)
call check(error, .not. is_lower(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_upper_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_upper('A'))
if (allocated(error)) return
call check(error, .not. is_upper('a'))
if (allocated(error)) return
call check(error, .not. is_upper('#'))
if (allocated(error)) return
! N.B.: does not return true for non-ASCII Unicode uppercase letters
call check(error, .not. is_upper('á'))
if (allocated(error)) return
call check(error, .not. is_upper('Á'))
if (allocated(error)) return
end subroutine
subroutine test_is_upper_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
do i = 1, len(uppercase)
call check(error, is_upper(uppercase(i:i)))
if (allocated(error)) return
end do
clist = digits//lowercase//whitespace
do i = 1, len(clist)
call check(error, .not. is_upper(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_digit_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_digit('3'))
if (allocated(error)) return
call check(error, is_digit('8'))
if (allocated(error)) return
call check(error, .not. is_digit('B'))
if (allocated(error)) return
call check(error, .not. is_digit('#'))
if (allocated(error)) return
! N.B.: does not return true for non-ASCII Unicode numbers
call check(error, .not. is_digit('０')) ! full-width digit zero (U+FF10)
if (allocated(error)) return
call check(error, .not. is_digit('４')) ! full-width digit four (U+FF14))
if (allocated(error)) return
end subroutine
subroutine test_is_digit_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
do i = 1, len(digits)
call check(error, is_digit(digits(i:i)))
if (allocated(error)) return
end do
clist = letters//whitespace
do i = 1, len(clist)
call check(error, .not. is_digit(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_octal_digit_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_octal_digit('0'))
if (allocated(error)) return
call check(error, is_octal_digit('7'))
if (allocated(error)) return
call check(error, .not. is_octal_digit('8'))
if (allocated(error)) return
call check(error, .not. is_octal_digit('A'))
if (allocated(error)) return
call check(error, .not. is_octal_digit('#'))
if (allocated(error)) return
end subroutine
subroutine test_is_octal_digit_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
do i = 1, len(octal_digits)
call check(error, is_octal_digit(octal_digits(i:i)))
if (allocated(error)) return
end do
clist = letters//'89'//whitespace
do i = 1, len(clist)
call check(error, .not. is_octal_digit(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_hex_digit_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_hex_digit('0'))
if (allocated(error)) return
call check(error, is_hex_digit('A'))
if (allocated(error)) return
call check(error, is_hex_digit('f')) !! lowercase hex digits are accepted
if (allocated(error)) return
call check(error, .not. is_hex_digit('g'))
if (allocated(error)) return
call check(error, .not. is_hex_digit('G'))
if (allocated(error)) return
call check(error, .not. is_hex_digit('#'))
if (allocated(error)) return
end subroutine
subroutine test_is_hex_digit_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
do i = 1, len(fullhex_digits)
call check(error, is_hex_digit(fullhex_digits(i:i)))
if (allocated(error)) return
end do
clist = lowercase(7:)//uppercase(7:)//whitespace
do i = 1, len(clist)
call check(error, .not. is_hex_digit(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_white_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_white(' '))
if (allocated(error)) return
call check(error, is_white(TAB))
if (allocated(error)) return
call check(error, is_white(LF))
if (allocated(error)) return
call check(error, .not. is_white('1'))
if (allocated(error)) return
call check(error, .not. is_white('a'))
if (allocated(error)) return
call check(error, .not. is_white('#'))
if (allocated(error)) return
end subroutine
subroutine test_is_white_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
do i = 1, len(whitespace)
call check(error, is_white(whitespace(i:i)))
if (allocated(error)) return
end do
clist = digits//letters
do i = 1, len(clist)
call check(error, .not. is_white(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_blank_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_blank(' '))
if (allocated(error)) return
call check(error, is_blank(TAB))
if (allocated(error)) return
call check(error, .not. is_blank('1'))
if (allocated(error)) return
call check(error, .not. is_blank('a'))
if (allocated(error)) return
call check(error, .not. is_blank('#'))
if (allocated(error)) return
end subroutine
subroutine test_is_blank_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
do i = 1, len(whitespace)
if (whitespace(i:i) == ' ' .or. whitespace(i:i) == TAB) then
call check(error, is_blank(whitespace(i:i)))
else
call check(error, .not. is_blank(whitespace(i:i)))
end if
if (allocated(error)) return
end do
clist = digits//letters
do i = 1, len(clist)
call check(error, .not. is_blank(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_control_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
! print *, is_control('\0')
! print *, is_control('\022')
call check(error, is_control(new_line('a'))) ! newline is both whitespace and control
if (allocated(error)) return
call check(error, .not. is_control(' '))
if (allocated(error)) return
call check(error, .not. is_control('1'))
if (allocated(error)) return
call check(error, .not. is_control('a'))
if (allocated(error)) return
call check(error, .not. is_control('#'))
if (allocated(error)) return
! N.B.: non-ASCII Unicode control characters are not recognized:
! print *, .not. is_control('\u0080')
! print *, .not. is_control('\u2028')
! print *, .not. is_control('\u2029')
end subroutine
subroutine test_is_control_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=:), allocatable :: clist
do i = 0, 31
call check(error, is_control(achar(i)))
if (allocated(error)) return
end do
call check(error, is_control(DEL))
if (allocated(error)) return
clist = digits//letters//' '
do i = 1, len(clist)
call check(error, .not. is_control(clist(i:i)))
if (allocated(error)) return
end do
end subroutine
subroutine test_is_punctuation_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_punctuation('.'))
if (allocated(error)) return
call check(error, is_punctuation(','))
if (allocated(error)) return
call check(error, is_punctuation(':'))
if (allocated(error)) return
call check(error, is_punctuation('!'))
if (allocated(error)) return
call check(error, is_punctuation('#'))
if (allocated(error)) return
call check(error, is_punctuation('~'))
if (allocated(error)) return
call check(error, is_punctuation('+'))
if (allocated(error)) return
call check(error, is_punctuation('_'))
if (allocated(error)) return
call check(error, .not. is_punctuation('1'))
if (allocated(error)) return
call check(error, .not. is_punctuation('a'))
if (allocated(error)) return
call check(error, .not. is_punctuation(' '))
if (allocated(error)) return
call check(error, .not. is_punctuation(LF)) ! new line character
if (allocated(error)) return
call check(error, .not. is_punctuation(NUL))
if (allocated(error)) return
! N.B.: Non-ASCII Unicode punctuation characters are not recognized.
! print *, is_punctuation('\u2012') ! (U+2012 = en-dash)
end subroutine
subroutine test_is_punctuation_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=1) :: c
do i = 0, 127
c = achar(i)
if (is_control(c) .or. is_alphanum(c) .or. c == ' ') then
call check(error, .not. is_punctuation(c))
else
call check(error, is_punctuation(c))
end if
if (allocated(error)) return
end do
end subroutine
subroutine test_is_graphical_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_graphical('1'))
if (allocated(error)) return
call check(error, is_graphical('a'))
if (allocated(error)) return
call check(error, is_graphical('#'))
if (allocated(error)) return
call check(error, .not. is_graphical(' ')) ! whitespace is not graphical
if (allocated(error)) return
call check(error, .not. is_graphical(LF))
if (allocated(error)) return
call check(error, .not. is_graphical(NUL))
if (allocated(error)) return
! N.B.: Unicode graphical characters are not regarded as such.
call check(error, .not. is_graphical('ä'))
if (allocated(error)) return
end subroutine
subroutine test_is_graphical_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=1) :: c
do i = 0, 127
c = achar(i)
if (is_control(c) .or. c == ' ') then
call check(error, .not. is_graphical(c))
else
call check(error, is_graphical(c))
end if
if (allocated(error)) return
end do
end subroutine
subroutine test_is_printable_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_printable(' ')) ! whitespace is printable
if (allocated(error)) return
call check(error, is_printable('1'))
if (allocated(error)) return
call check(error, is_printable('a'))
if (allocated(error)) return
call check(error, is_printable('#'))
if (allocated(error)) return
call check(error, .not. is_printable(NUL)) ! control characters are not printable
if (allocated(error)) return
! N.B.: Printable non-ASCII Unicode characters are not recognized.
call check(error, .not. is_printable('ä'))
if (allocated(error)) return
end subroutine
subroutine test_is_printable_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=1) :: c
do i = 0, 127
c = achar(i)
if (is_control(c)) then
call check(error, .not. is_printable(c))
else
call check(error, is_printable(c))
end if
if (allocated(error)) return
end do
end subroutine
subroutine test_is_ascii_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, is_ascii('a'))
if (allocated(error)) return
call check(error, .not. is_ascii('ä'))
if (allocated(error)) return
end subroutine
subroutine test_is_ascii_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
do i = 0, 127
call check(error, is_ascii(achar(i)))
if (allocated(error)) return
end do
call check(error, .not. is_ascii(achar(128))) ! raises compiler warning
if (allocated(error)) return
end subroutine
subroutine test_to_lower_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, to_lower('a'), 'a')
if (allocated(error)) return
call check(error, to_lower('A'), 'a')
if (allocated(error)) return
call check(error, to_lower('#'), '#')
if (allocated(error)) return
end subroutine
subroutine test_to_lower_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=1) :: c
do i = 1, len(uppercase)
call check(error, to_lower(uppercase(i:i)), lowercase(i:i))
if (allocated(error)) return
end do
do i = 0, 127
c = achar(i)
if (c < 'A' .or. c > 'Z') then
call check(error, to_lower(c), c)
else
call check(error, to_lower(c) /= c)
end if
if (allocated(error)) return
end do
end subroutine
subroutine test_to_upper_short(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, to_upper('a'), 'A')
if (allocated(error)) return
call check(error, to_upper('A'), 'A')
if (allocated(error)) return
call check(error, to_upper('#'), '#')
if (allocated(error)) return
end subroutine
subroutine test_to_upper_long(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
character(len=1) :: c
do i = 1, len(lowercase)
call check(error, to_upper(lowercase(i:i)), uppercase(i:i))
if (allocated(error)) return
end do
do i = 0, 127
c = achar(i)
if (c < 'a' .or. c > 'z') then
call check(error, to_upper(c), c)
else
call check(error, to_upper(c) /= c)
end if
if (allocated(error)) return
end do
end subroutine
!
! This test reproduces the true/false table found at
! https://en.cppreference.com/w/cpp/string/byte
!
subroutine ascii_table(table)
logical, intent(out) :: table(15,12)
integer :: i, j
! loop through functions
do i = 1, 12
table(1,i) = all([(validate(j,i), j=0,8)])
table(2,i) = validate(9,i)
table(3,i) = all([(validate(j,i), j=10,13)])
table(4,i) = all([(validate(j,i), j=14,31)])
table(5,i) = validate(32,i)
table(6,i) = all([(validate(j,i), j=33,47)])
table(7,i) = all([(validate(j,i), j=48,57)])
table(8,i) = all([(validate(j,i), j=58,64)])
table(9,i) = all([(validate(j,i), j=65,70)])
table(10,i) = all([(validate(j,i), j=71,90)])
table(11,i) = all([(validate(j,i), j=91,96)])
table(12,i) = all([(validate(j,i), j=97,102)])
table(13,i) = all([(validate(j,i), j=103,122)])
table(14,i) = all([(validate(j,i), j=123,126)])
table(15,i) = validate(127,i)
end do
! output table for verification
write(*,'(5X,12(I4))') (i,i=1,12)
do j = 1, 15
write(*,'(I3,2X,12(L4),2X,I3)') j, (table(j,i),i=1,12), count(table(j,:))
end do
write(*,'(5X,12(I4))') (count(table(:,i)),i=1,12)
contains
elemental logical function validate(ascii_code, func)
integer, intent(in) :: ascii_code, func
character(len=1) :: c
c = achar(ascii_code)
select case (func)
case (1); validate = is_control(c)
case (2); validate = is_printable(c)
case (3); validate = is_white(c)
case (4); validate = is_blank(c)
case (5); validate = is_graphical(c)
case (6); validate = is_punctuation(c)
case (7); validate = is_alphanum(c)
case (8); validate = is_alpha(c)
case (9); validate = is_upper(c)
case (10); validate = is_lower(c)
case (11); validate = is_digit(c)
case (12); validate = is_hex_digit(c)
case default; validate = .false.
end select
end function validate
end subroutine ascii_table
subroutine test_ascii_table(error)
type(error_type), allocatable, intent(out) :: error
logical :: arr(15, 12)
logical, parameter :: ascii_class_table(15,12) = transpose(reshape([ &
! iscntrl isprint isspace isblank isgraph ispunct isalnum isalpha isupper islower isdigit isxdigit
.true., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 0–8
.true., .false., .true., .true., .false., .false., .false., .false., .false., .false., .false., .false., & ! 9
.true., .false., .true., .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 10–13
.true., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., & ! 14–31
.false., .true., .true., .true., .false., .false., .false., .false., .false., .false., .false., .false., & ! 32 (space)
.false., .true., .false., .false., .true., .true., .false., .false., .false., .false., .false., .false., & ! 33–47
.false., .true., .false., .false., .true., .false., .true., .false., .false., .false., .true., .true., & ! 48–57
.false., .true., .false., .false., .true., .true., .false., .false., .false., .false., .false., .false., & ! 58–64
.false., .true., .false., .false., .true., .false., .true., .true., .true., .false., .false., .true., & ! 65–70
.false., .true., .false., .false., .true., .false., .true., .true., .true., .false., .false., .false., & ! 71–90
.false., .true., .false., .false., .true., .true., .false., .false., .false., .false., .false., .false., & ! 91–96
.false., .true., .false., .false., .true., .false., .true., .true., .false., .true., .false., .true., & ! 97–102
.false., .true., .false., .false., .true., .false., .true., .true., .false., .true., .false., .false., & ! 103–122
.false., .true., .false., .false., .true., .true., .false., .false., .false., .false., .false., .false., & ! 123–126
.true., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false. & ! 127
], shape=[12,15]))
call ascii_table(arr)
call check(error, all(arr .eqv. ascii_class_table), "ascii table was not accurately generated")
end subroutine test_ascii_table
subroutine test_to_lower_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: dlc
character(len=32), parameter :: input = "UPPERCASE"
dlc = to_lower("UPPERCASE")
call check(error, dlc, "uppercase")
if (allocated(error)) return
dlc = to_lower(input)
call check(error, len(dlc), 32)
if (allocated(error)) return
call check(error, len_trim(dlc), 9)
if (allocated(error)) return
call check(error, trim(dlc), "uppercase")
if (allocated(error)) return
dlc = to_lower("0123456789ABCDE")
call check(error, dlc, "0123456789abcde")
if (allocated(error)) return
end subroutine test_to_lower_string
subroutine test_to_upper_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: dlc
character(len=32), parameter :: input = "lowercase"
dlc = to_upper("lowercase")
call check(error, dlc, "LOWERCASE")
if (allocated(error)) return
dlc = to_upper(input)
call check(error, len(dlc), 32)
if (allocated(error)) return
call check(error, len_trim(dlc), 9)
if (allocated(error)) return
call check(error, trim(dlc), "LOWERCASE")
if (allocated(error)) return
dlc = to_upper("0123456789abcde")
call check(error, dlc, "0123456789ABCDE")
if (allocated(error)) return
end subroutine test_to_upper_string
subroutine test_to_title_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: dlc
character(len=32), parameter :: input = "tHis Is tO bE tiTlEd"
dlc = to_title("tHis Is tO bE tiTlEd")
call check(error, dlc, "This Is To Be Titled")
if (allocated(error)) return
dlc = to_title(input)
call check(error, len(dlc), 32)
if (allocated(error)) return
call check(error, len_trim(dlc), 20)
if (allocated(error)) return
call check(error, trim(dlc), "This Is To Be Titled")
if (allocated(error)) return
dlc = to_title(" s P a C e D !")
call check(error, dlc, " S P A C E D !")
if (allocated(error)) return
dlc = to_title("1st, 2nD, 3RD")
call check(error, dlc, "1st, 2nd, 3rd")
if (allocated(error)) return
dlc = to_title("""quOTed""")
call check(error, dlc, """Quoted""")
if (allocated(error)) return
end subroutine test_to_title_string
subroutine test_to_sentence_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: dlc
character(len=32), parameter :: input = "tHis iS A seNteNcE."
dlc = to_sentence("tHis iS A seNteNcE.")
call check(error, dlc, "This is a sentence.")
if (allocated(error)) return
dlc = to_sentence(input)
call check(error, len(dlc), 32)
if (allocated(error)) return
call check(error, len_trim(dlc), 19)
if (allocated(error)) return
call check(error, trim(dlc), "This is a sentence.")
if (allocated(error)) return
dlc = to_sentence(" s P a C e D !")
call check(error, dlc, " S p a c e d !")
if (allocated(error)) return
dlc = to_sentence("1st, 2nd, 3rd")
call check(error, dlc, "1st, 2nd, 3rd")
if (allocated(error)) return
dlc = to_sentence("""quOTed""")
call check(error, dlc, """Quoted""")
if (allocated(error)) return
end subroutine test_to_sentence_string
subroutine test_reverse_string(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: dlc
character(len=32), parameter :: input = "reversed"
dlc = reverse("reversed")
call check(error, dlc, "desrever")
if (allocated(error)) return
dlc = reverse(input)
call check(error, len(dlc), 32)
if (allocated(error)) return
call check(error, len_trim(dlc), 32)
if (allocated(error)) return
call check(error, trim(dlc), " desrever")
if (allocated(error)) return
call check(error, trim(adjustl(dlc)), "desrever")
if (allocated(error)) return
end subroutine test_reverse_string
end module test_ascii
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_ascii, only : collect_ascii
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("ascii", collect_ascii) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/hashmaps/ 0000775 0001750 0001750 00000000000 15135654166 020751 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/hashmaps/CMakeLists.txt 0000775 0001750 0001750 00000000345 15135654166 023516 0 ustar alastair alastair ### Pre-process: .fpp -> .f90 via Fypp
# Create a list of the files to be preprocessed
set(fppFiles
test_maps.fypp
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(chaining_maps)
ADDTEST(open_maps)
ADDTEST(maps)
fortran-lang-stdlib-0ede301/test/hashmaps/test_open_maps.f90 0000775 0001750 0001750 00000034227 15135654166 024324 0 ustar alastair alastair program test_open_maps
!! Test various aspects of the runtime system.
!! Running this program may require increasing the stack size to above 48 MBytes
!! or decreasing rand_power to 20 or less
use stdlib_kinds, only: &
dp, &
int8, &
int32
use stdlib_hashmaps, only : open_hashmap_type, int_depth, int_index
use stdlib_hashmap_wrappers
implicit none
type dummy_type
integer(int8), allocatable :: value(:)
end type dummy_type
integer(int32), parameter :: huge32 = huge(0_int32)
real(dp), parameter :: hugep1 = real(huge32, dp) + 1.0_dp
integer, parameter :: rand_power = 18
integer, parameter :: rand_size = 2**rand_power
integer, parameter :: test_size = rand_size*4
integer, parameter :: test_16 = 2**4
integer, parameter :: test_256 = 2**8
integer :: index
integer :: lun
type(open_hashmap_type) :: map
real(dp) :: rand2(2)
integer(int32) :: rand_object(rand_size)
integer(int8) :: test_8_bits(test_size)
open( newunit=lun, file="test_open_maps.txt", access="sequential", &
action="write", form="formatted", position="rewind" )
write(lun, '("| ", a17, " | ", a12, " | ", a15, " | ", a10, " |")') &
'Algorithm', 'Process', 'Data Set', 'Time (s)'
do index=1, rand_size
call random_number(rand2)
if (rand2(1) < 0.5_dp) then
rand_object(index) = ceiling(-rand2(2)*hugep1, int32) - 1
else
rand_object(index) = floor(rand2(2)*hugep1, int32)
end if
end do
test_8_bits(:) = transfer( rand_object, 0_int8, test_size )
! Test implicit initalization by skipping init call for first test.
call input_random_data( map, test_16, 'FNV-1', "16 byte words" )
call test_inquire_data( map, test_16, 'FNV-1', "16 byte words" )
call test_get_data( map, test_16, 'FNV-1', '16 byte words' )
call test_get_all_keys( map, test_16, 'FNV-1', '16 byte words' )
call report_rehash_times( map, fnv_1_hasher, 'FNV-1', '16 byte words' )
call report_hash_statistics( map, 'FNV-1', '16 byte words' )
call report_removal_times( map, test_16, 'FNV-1', '16 byte words' )
call map % init() ! Test default options
call input_random_data( map, test_256, 'FNV-1', "256 byte words" )
call test_inquire_data( map, test_256, 'FNV-1', "256 byte words" )
call test_get_data( map, test_256, 'FNV-1', '256 byte words' )
call test_get_all_keys( map, test_256, 'FNV-1', '256 byte words' )
call report_rehash_times( map, fnv_1_hasher, 'FNV-1', '256 byte words' )
call report_hash_statistics( map, 'FNV-1', '256 byte words' )
call report_removal_times( map, test_256, 'FNV-1', '256 byte words' )
call map % init( fnv_1a_hasher, slots_bits=10 )
call input_random_data( map, test_16, 'FNV-1A', "16 byte words" )
call test_inquire_data( map, test_16, 'FNV-1A', "16 byte words" )
call test_get_data( map, test_16, 'FNV-1A', '16 byte words' )
call test_get_all_keys( map, test_16, 'FNV-1A', '16 byte words' )
call report_rehash_times( map, fnv_1a_hasher, 'FNV-1', '16 byte words' )
call report_hash_statistics( map, 'FNV-1A', '16 byte words' )
call report_removal_times( map, test_16, 'FNV-1a', '16 byte words' )
call map % init( fnv_1a_hasher, slots_bits=10 )
call input_random_data( map, test_256, 'FNV-1A', "256 byte words" )
call test_inquire_data( map, test_256, 'FNV-1A', "256 byte words" )
call test_get_data( map, test_256, 'FNV-1A', '256 byte words' )
call test_get_all_keys( map, test_256, 'FNV-1A', '256 byte words' )
call report_rehash_times( map, fnv_1_hasher, 'FNV-1A', '256 byte words' )
call report_hash_statistics( map, 'FNV-1A', '256 byte words' )
call report_removal_times( map, test_256, 'FNV-1A', '256 byte words' )
call map % init( seeded_nmhash32_hasher, slots_bits=10 )
call input_random_data( map, test_16, 'Seeded_Nmhash32', "16 byte words" )
call test_inquire_data( map, test_16, 'Seeded_Nmhash32', "16 byte words" )
call test_get_data( map, test_16, 'Seeded_Nmhash32', '16 byte words' )
call test_get_all_keys( map, test_16, 'Seeded_Nmhash32', '16 byte words' )
call report_rehash_times( map, seeded_nmhash32_hasher, 'Seeded_Nmhash32', &
'16 byte words' )
call report_hash_statistics( map, 'Seeded_Nmhash32', '16 byte words' )
call report_removal_times( map, test_16, 'Seeded_Nmhash32', &
'16 byte words' )
call map % init( seeded_nmhash32_hasher, slots_bits=10 )
call input_random_data( map, test_256, 'Seeded_Nmhash32', "256 byte words" )
call test_inquire_data( map, test_256, 'Seeded_Nmhash32', "256 byte words" )
call test_get_data( map, test_256, 'Seeded_Nmhash32', '256 byte words' )
call test_get_all_keys( map, test_256, 'Seeded_Nmhash32', '256 byte words' )
call report_rehash_times( map, seeded_nmhash32_hasher, 'Seeded_Nmhash32', &
'256 byte words' )
call report_hash_statistics( map, 'Seeded_Nmhash32', '256 byte words' )
call report_removal_times( map, test_256, 'Seeded_Nmhash32', &
'256 byte words' )
call map % init( seeded_nmhash32x_hasher, slots_bits=10 )
call input_random_data( map, test_16, 'Seeded_Nmhash32x', "16 byte words" )
call test_inquire_data( map, test_16, 'Seeded_Nmhash32x', "16 byte words" )
call test_get_data( map, test_16, 'Seeded_Nmhash32x', '16 byte words' )
call test_get_all_keys( map, test_16, 'Seeded_Nmhash32x', '16 byte words' )
call report_rehash_times( map, seeded_nmhash32x_hasher, &
'Seeded_Nmhash32x', '16 byte words' )
call report_hash_statistics( map, 'Seeded_Nmhash32x', '16 byte words' )
call report_removal_times( map, test_16, 'Seeded_Nmhash32x', &
'16 byte words' )
call map % init( seeded_nmhash32x_hasher, slots_bits=10 )
call input_random_data( map, test_256, 'Seeded_Nmhash32x', &
"256 byte words" )
call test_inquire_data( map, test_256, 'Seeded_Nmhash32x', &
"256 byte words" )
call test_get_data( map, test_256, 'Seeded_Nmhash32x', '256 byte words' )
call test_get_all_keys( map, test_256, 'Seeded_Nmhash32x', '256 byte words' )
call report_rehash_times( map, seeded_nmhash32x_hasher, &
'Seeded_Nmhash32x', '256 byte words' )
call report_hash_statistics( map, 'Seeded_Nmhash32x', '256 byte words' )
call report_removal_times( map, test_256, 'Seeded_Nmhash32x', &
'256 byte words' )
call map % init( seeded_water_hasher, slots_bits=10 )
call input_random_data( map, test_16, 'Seeded_Water', "16 byte words" )
call test_inquire_data( map, test_16, 'Seeded_Water', "16 byte words" )
call test_get_data( map, test_16, 'Seeded_Water', '16 byte words' )
call test_get_all_keys( map, test_16, 'Seeded_Water', '16 byte words' )
call report_rehash_times( map, seeded_water_hasher, &
'Seeded_Water', '16 byte words' )
call report_hash_statistics( map, 'Seeded_Water', '16 byte words' )
call report_removal_times( map, test_16, 'Seeded_Water', &
'16 byte words' )
call map % init( seeded_water_hasher, slots_bits=10 )
call input_random_data( map, test_256, 'Seeded_Water', &
"256 byte words" )
call test_inquire_data( map, test_256, 'Seeded_Water', &
"256 byte words" )
call test_get_data( map, test_256, 'Seeded_Water', '256 byte words' )
call test_get_all_keys( map, test_256, 'Seeded_Water', '256 byte words' )
call report_rehash_times( map, seeded_water_hasher, &
'Seeded_Water', '256 byte words' )
call report_hash_statistics( map, 'Seeded_Water', '256 byte words' )
call report_removal_times( map, test_256, 'Seeded_Water', &
'256 byte words' )
contains
subroutine input_random_data( map, test_block, hash_name, size_name )
type(open_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name
character(*), intent(in) :: size_name
type(dummy_type) :: dummy_val
integer :: index2
type(key_type) :: key
real :: t1, t2, tdiff
logical :: conflict
call cpu_time(t1)
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
dummy_val % value = test_8_bits( index2:index2+test_block-1 )
call map % map_entry( key, dummy_val, conflict )
if (conflict) &
error stop "Unable to map entry because of a key conflict."
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Enter data', size_name, tdiff
end subroutine input_random_data
subroutine test_inquire_data( map, test_block, hash_name, size_name )
type(open_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name, size_name
integer :: index2
logical :: present
type(key_type) :: key
real :: t1, t2, tdiff
call cpu_time(t1)
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
call map % key_test( key, present )
if (.not. present) &
error stop "KEY not found in map KEY_TEST."
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Inquire data', size_name, tdiff
end subroutine test_inquire_data
subroutine test_get_data( map, test_block, hash_name, size_name )
type(open_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name, size_name
integer :: index2
type(key_type) :: key
class(*), allocatable :: data
logical :: exists
real :: t1, t2, tdiff
call cpu_time(t1)
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
call map % get_other_data( key, data, exists )
if (.not. exists) &
error stop "Unable to get data because key not found in map."
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Get data', size_name, tdiff
end subroutine test_get_data
subroutine test_get_all_keys( map, test_block, hash_name, size_name )
type(open_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name, size_name
integer :: index2, key_idx
type(key_type) :: key
type(key_type), allocatable :: all_keys(:)
real :: t1, t2, tdiff
call cpu_time(t1)
call map % get_all_keys(all_keys)
call cpu_time(t2)
tdiff = t2-t1
if (size( all_keys ) /= size( test_8_bits )/test_block) &
error stop "Number of keys is different from that of keys in a map."
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
key_idx = ( index2/test_block ) + 1
if (.not. ( all_keys(key_idx) == key )) &
error stop "Invalid value of a key."
end do
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Get all keys', size_name, tdiff
end subroutine test_get_all_keys
subroutine report_rehash_times( map, hasher, hash_name, size_name )
type(open_hashmap_type), intent(inout) :: map
procedure(hasher_fun) :: hasher
character(*), intent(in) :: hash_name, size_name
real :: t1, t2, tdiff
call cpu_time(t1)
call map % rehash( hasher )
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Rehash data', size_name, tdiff
end subroutine report_rehash_times
subroutine report_removal_times( map, test_block, hash_name, size_name )
type(open_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name, size_name
real :: t1, t2, tdiff
type(key_type) :: key
integer(int_index) :: index2
logical :: existed
call cpu_time(t1)
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
call map % remove(key, existed)
if ( .not. existed ) &
error stop "Key not found in entry removal."
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Remove data', size_name, tdiff
flush(lun)
end subroutine report_removal_times
subroutine report_hash_statistics( map, hash_name, size_name )
type(open_hashmap_type), intent(inout) :: map
character(*), intent(in) :: hash_name, size_name
integer(int_depth) :: depth
write(lun, *)
write(lun, '("Statistics for open hash table with ",' // &
'A, " hasher on ", A, ".")' ) hash_name, size_name
write(lun, '("Slots = ", I0)' ) map % num_slots()
write(lun, '("Calls = ", I0)' ) map % calls()
write(lun, '("Entries = ", I0)' ) map % entries()
write(lun, '("Total probes = ", I0)' ) map % map_probes()
write(lun, '("Loading = ", ES10.3)' ) map % loading()
depth = map % total_depth()
write(lun, '("Total depth = ", I0)' ) depth
write(lun, '("Relative depth = ", ES10.3)') &
real( depth ) / real( map % entries() )
end subroutine report_hash_statistics
end program test_open_maps
fortran-lang-stdlib-0ede301/test/hashmaps/test_chaining_maps.f90 0000775 0001750 0001750 00000034262 15135654166 025142 0 ustar alastair alastair program test_chaining_maps
!! Test various aspects of the runtime system.
!! Running this program may require increasing the stack size to above 48 MBytes
!! or decreasing rand_power to 20 or less
use stdlib_kinds, only: &
dp, &
int8, &
int32
use stdlib_hashmaps, only : chaining_hashmap_type, int_depth, int_index
use stdlib_hashmap_wrappers
implicit none
type dummy_type
integer(int8), allocatable :: value(:)
end type dummy_type
integer(int32), parameter :: huge32 = huge(0_int32)
real(dp), parameter :: hugep1 = real(huge32, dp) + 1.0_dp
integer, parameter :: rand_power = 18
integer, parameter :: rand_size = 2**rand_power
integer, parameter :: test_size = rand_size*4
integer, parameter :: test_16 = 2**4
integer, parameter :: test_256 = 2**8
integer :: index
integer :: lun
type(chaining_hashmap_type) :: map
real(dp) :: rand2(2)
integer(int32) :: rand_object(rand_size)
integer(int8) :: test_8_bits(test_size)
open( newunit=lun, file="test_chaining_maps.txt", access="sequential", &
action="write", form="formatted", position="rewind" )
write(lun, '("| ", a17, " | ", a12, " | ", a15, " | ", a10, " |")') &
'Algorithm', 'Process', 'Data Set', 'Time (s)'
do index=1, rand_size
call random_number(rand2)
if (rand2(1) < 0.5_dp) then
rand_object(index) = ceiling(-rand2(2)*hugep1, int32) - 1
else
rand_object(index) = floor(rand2(2)*hugep1, int32)
end if
end do
test_8_bits(:) = transfer( rand_object, 0_int8, test_size )
! Test implicit initalization by skipping init call for first test.
call input_random_data( map, test_16, 'FNV-1', "16 byte words" )
call test_inquire_data( map, test_16, 'FNV-1', "16 byte words" )
call test_get_all_keys( map, test_16, 'FNV-1', '16 byte words' )
call test_get_data( map, test_16, 'FNV-1', '16 byte words' )
call report_rehash_times( map, fnv_1_hasher, 'FNV-1', '16 byte words' )
call report_hash_statistics( map, 'FNV-1', '16 byte words' )
call report_removal_times( map, test_16, 'FNV-1', '16 byte words' )
call map % init() ! Test default options
call input_random_data( map, test_256, 'FNV-1', "256 byte words" )
call test_inquire_data( map, test_256, 'FNV-1', "256 byte words" )
call test_get_data( map, test_256, 'FNV-1', '256 byte words' )
call test_get_all_keys( map, test_256, 'FNV-1', '256 byte words' )
call report_rehash_times( map, fnv_1_hasher, 'FNV-1', '256 byte words' )
call report_hash_statistics( map, 'FNV-1', '256 byte words' )
call report_removal_times( map, test_256, 'FNV-1', '256 byte words' )
call map % init( fnv_1a_hasher, slots_bits=10 )
call input_random_data( map, test_16, 'FNV-1A', "16 byte words" )
call test_inquire_data( map, test_16, 'FNV-1A', "16 byte words" )
call test_get_data( map, test_16, 'FNV-1A', '16 byte words' )
call test_get_all_keys( map, test_16, 'FNV-1A', '16 byte words' )
call report_rehash_times( map, fnv_1a_hasher, 'FNV-1', '16 byte words' )
call report_hash_statistics( map, 'FNV-1A', '16 byte words' )
call report_removal_times( map, test_16, 'FNV-1a', '16 byte words' )
call map % init( fnv_1a_hasher, slots_bits=10 )
call input_random_data( map, test_256, 'FNV-1A', "256 byte words" )
call test_inquire_data( map, test_256, 'FNV-1A', "256 byte words" )
call test_get_data( map, test_256, 'FNV-1A', '256 byte words' )
call test_get_all_keys( map, test_256, 'FNV-1A', '256 byte words' )
call report_rehash_times( map, fnv_1_hasher, 'FNV-1A', '256 byte words' )
call report_hash_statistics( map, 'FNV-1A', '256 byte words' )
call report_removal_times( map, test_256, 'FNV-1A', '256 byte words' )
call map % init( seeded_nmhash32_hasher, slots_bits=10 )
call input_random_data( map, test_16, 'Seeded_Nmhash32', "16 byte words" )
call test_inquire_data( map, test_16, 'Seeded_Nmhash32', "16 byte words" )
call test_get_data( map, test_16, 'Seeded_Nmhash32', '16 byte words' )
call test_get_all_keys( map, test_16, 'Seeded_Nmhash32', '16 byte words' )
call report_rehash_times( map, seeded_nmhash32_hasher, 'Seeded_Nmhash32', &
'16 byte words' )
call report_hash_statistics( map, 'Seeded_Nmhash32', '16 byte words' )
call report_removal_times( map, test_16, 'Seeded_Nmhash32', &
'16 byte words' )
call map % init( seeded_nmhash32_hasher, slots_bits=10 )
call input_random_data( map, test_256, 'Seeded_Nmhash32', "256 byte words" )
call test_inquire_data( map, test_256, 'Seeded_Nmhash32', "256 byte words" )
call test_get_data( map, test_256, 'Seeded_Nmhash32', '256 byte words' )
call test_get_all_keys( map, test_256, 'Seeded_Nmhash32', '256 byte words' )
call report_rehash_times( map, seeded_nmhash32_hasher, 'Seeded_Nmhash32', &
'256 byte words' )
call report_hash_statistics( map, 'Seeded_Nmhash32', '256 byte words' )
call report_removal_times( map, test_256, 'Seeded_Nmhash32', &
'256 byte words' )
call map % init( seeded_nmhash32x_hasher, slots_bits=10 )
call input_random_data( map, test_16, 'Seeded_Nmhash32x', "16 byte words" )
call test_inquire_data( map, test_16, 'Seeded_Nmhash32x', "16 byte words" )
call test_get_data( map, test_16, 'Seeded_Nmhash32x', '16 byte words' )
call test_get_all_keys( map, test_16, 'Seeded_Nmhash32x', '16 byte words' )
call report_rehash_times( map, seeded_nmhash32x_hasher, &
'Seeded_Nmhash32x', '16 byte words' )
call report_hash_statistics( map, 'Seeded_Nmhash32x', '16 byte words' )
call report_removal_times( map, test_16, 'Seeded_Nmhash32x', &
'16 byte words' )
call map % init( seeded_nmhash32x_hasher, slots_bits=10 )
call input_random_data( map, test_256, 'Seeded_Nmhash32x', &
"256 byte words" )
call test_inquire_data( map, test_256, 'Seeded_Nmhash32x', &
"256 byte words" )
call test_get_data( map, test_256, 'Seeded_Nmhash32x', '256 byte words' )
call test_get_all_keys( map, test_256, 'Seeded_Nmhash32x', '256 byte words' )
call report_rehash_times( map, seeded_nmhash32x_hasher, &
'Seeded_Nmhash32x', '256 byte words' )
call report_hash_statistics( map, 'Seeded_Nmhash32x', '256 byte words' )
call report_removal_times( map, test_256, 'Seeded_Nmhash32x', &
'256 byte words' )
call map % init( seeded_water_hasher, slots_bits=10 )
call input_random_data( map, test_16, 'Seeded_Water', "16 byte words" )
call test_inquire_data( map, test_16, 'Seeded_Water', "16 byte words" )
call test_get_data( map, test_16, 'Seeded_Water', '16 byte words' )
call test_get_all_keys( map, test_16, 'Seeded_Water', '16 byte words' )
call report_rehash_times( map, seeded_water_hasher, &
'Seeded_Water', '16 byte words' )
call report_hash_statistics( map, 'Seeded_Water', '16 byte words' )
call report_removal_times( map, test_16, 'Seeded_Water', &
'16 byte words' )
call map % init( seeded_water_hasher, slots_bits=10 )
call input_random_data( map, test_256, 'Seeded_Water', &
"256 byte words" )
call test_inquire_data( map, test_256, 'Seeded_Water', &
"256 byte words" )
call test_get_data( map, test_256, 'Seeded_Water', '256 byte words' )
call test_get_all_keys( map, test_256, 'Seeded_Water', '256 byte words' )
call report_rehash_times( map, seeded_water_hasher, &
'Seeded_Water', '256 byte words' )
call report_hash_statistics( map, 'Seeded_Water', '256 byte words' )
call report_removal_times( map, test_256, 'Seeded_Water', &
'256 byte words' )
contains
subroutine input_random_data( map, test_block, hash_name, size_name )
type(chaining_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name
character(*), intent(in) :: size_name
type(dummy_type) :: dummy_val
integer :: index2
type(key_type) :: key
real :: t1, t2, tdiff
logical :: conflict
call cpu_time(t1)
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
dummy_val % value = test_8_bits( index2:index2+test_block-1 )
call map % map_entry( key, dummy_val, conflict )
if (conflict) &
error stop "Unable to map entry because of a key conflict."
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Enter data', size_name, tdiff
end subroutine input_random_data
subroutine test_inquire_data( map, test_block, hash_name, size_name )
type(chaining_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name, size_name
integer :: index2
logical :: present
type(key_type) :: key
real :: t1, t2, tdiff
call cpu_time(t1)
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
call map % key_test( key, present )
if (.not. present) &
error stop "KEY not found in map KEY_TEST."
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Inquire data', size_name, tdiff
end subroutine test_inquire_data
subroutine test_get_data( map, test_block, hash_name, size_name )
type(chaining_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name, size_name
integer :: index2
type(key_type) :: key
class(*), allocatable :: data
logical :: exists
real :: t1, t2, tdiff
call cpu_time(t1)
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
call map % get_other_data( key, data, exists )
if (.not. exists) &
error stop "Unable to get data because key not found in map."
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Get data', size_name, tdiff
end subroutine test_get_data
subroutine test_get_all_keys( map, test_block, hash_name, size_name )
type(chaining_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name, size_name
integer :: index2, key_idx
type(key_type) :: key
type(key_type), allocatable :: all_keys(:)
real :: t1, t2, tdiff
call cpu_time(t1)
call map % get_all_keys(all_keys)
call cpu_time(t2)
tdiff = t2-t1
if (size( all_keys ) /= size( test_8_bits )/test_block) &
error stop "Number of keys is different from that of keys in a map."
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
key_idx = ( index2/test_block ) + 1
if (.not. ( all_keys(key_idx) == key )) &
error stop "Invalid value of a key."
end do
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Get all keys', size_name, tdiff
end subroutine test_get_all_keys
subroutine report_rehash_times( map, hasher, hash_name, size_name )
type(chaining_hashmap_type), intent(inout) :: map
procedure(hasher_fun) :: hasher
character(*), intent(in) :: hash_name, size_name
real :: t1, t2, tdiff
call cpu_time(t1)
call map % rehash( hasher )
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Rehash data', size_name, tdiff
end subroutine report_rehash_times
subroutine report_removal_times( map, test_block, hash_name, size_name )
type(chaining_hashmap_type), intent(inout) :: map
integer(int_index), intent(in) :: test_block
character(*), intent(in) :: hash_name, size_name
real :: t1, t2, tdiff
type(key_type) :: key
integer(int_index) :: index2
logical :: existed
call cpu_time(t1)
do index2=1, size(test_8_bits), test_block
call set( key, test_8_bits( index2:index2+test_block-1 ) )
call map % remove(key, existed)
if ( .not. existed ) &
error stop "Key not found in entry removal."
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a18, " | ", a12, " | ", a15, " | ", f10.5, " |")') &
trim(hash_name), 'Remove data', size_name, tdiff
flush(lun)
end subroutine report_removal_times
subroutine report_hash_statistics( map, hash_name, size_name )
type(chaining_hashmap_type), intent(inout) :: map
character(*), intent(in) :: hash_name, size_name
integer(int_depth) :: depth
write(lun, *)
write(lun, '("Statistics for chaining hash table with ",' // &
'A, " hasher on ", A, ".")' ) hash_name, size_name
write(lun, '("Slots = ", I0)' ) map % num_slots()
write(lun, '("Calls = ", I0)' ) map % calls()
write(lun, '("Entries = ", I0)' ) map % entries()
write(lun, '("Total probes = ", I0)' ) map % map_probes()
write(lun, '("Loading = ", ES10.3)' ) map % loading()
depth = map % total_depth()
write(lun, '("Total depth = ", I0)' ) depth
write(lun, '("Relative depth = ", ES10.3)') &
real( depth ) / real( map % entries() )
end subroutine report_hash_statistics
end program test_chaining_maps
fortran-lang-stdlib-0ede301/test/hashmaps/Makefile.manual 0000775 0001750 0001750 00000000151 15135654166 023665 0 ustar alastair alastair PROGS_SRC = test_chaining_maps.f90 \
test_open_maps.f90
include ../Makefile.manual.test.mk
fortran-lang-stdlib-0ede301/test/hashmaps/test_maps.fypp 0000664 0001750 0001750 00000062515 15135654166 023661 0 ustar alastair alastair #: include "common.fypp"
#:set HASH_NAME = ["fnv_1_hasher", "fnv_1a_hasher", "seeded_nmhash32_hasher", "seeded_nmhash32x_hasher", "seeded_water_hasher"]
#:set SIZE_NAME = ["16", "256"]
module test_stdlib_chaining_maps
!! Test various aspects of the runtime system.
!! Running this program may require increasing the stack size to above 48 MBytes
!! or decreasing rand_power to 20 or less
use testdrive, only : new_unittest, unittest_type, error_type, check
use :: stdlib_kinds, only : dp, int8, int32
use stdlib_hashmaps, only : chaining_hashmap_type, int_depth, int_index
use stdlib_hashmap_wrappers
implicit none
private
type dummy_type
integer(int8), allocatable :: value(:)
end type dummy_type
integer(int32), parameter :: huge32 = huge(0_int32)
real(dp), parameter :: hugep1 = real(huge32, dp) + 1.0_dp
integer, parameter :: rand_power = 18
integer, parameter :: rand_size = 2**rand_power
integer, parameter :: test_size = rand_size*4
integer, parameter :: test_16 = 2**4
integer, parameter :: test_256 = 2**8
! key_type = 5 to support int8 and int32 key types tested. Can be
! increased to generate additional unique int8 vectors additional key types.
integer, parameter :: key_types = 5
character(len=16) :: char_size
public :: collect_stdlib_chaining_maps
contains
!> Collect all exported unit tests
subroutine collect_stdlib_chaining_maps(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("chaining-maps-fnv_1_hasher-16-byte-words", test_fnv_1_hasher_16_byte_words) &
#:for hash_ in HASH_NAME
#:for size_ in SIZE_NAME
, new_unittest("chaining-maps-${hash_}$-${size_}$-byte-words", test_${hash_}$_${size_}$_byte_words) &
#:endfor
#:endfor
, new_unittest("chaining-maps-removal-spec", test_removal_spec) &
]
end subroutine collect_stdlib_chaining_maps
#:for hash_ in HASH_NAME
#:for size_ in SIZE_NAME
subroutine test_${hash_}$_${size_}$_byte_words(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(chaining_hashmap_type) :: map
integer(int8) :: test_8_bits(test_size,key_types)
call generate_vector(test_8_bits)
call map % init( ${hash_}$, slots_bits=10 )
call test_input_random_data(error, map, test_8_bits, test_${size_}$)
if (allocated(error)) return
call test_inquire_data(error, map, test_8_bits, test_${size_}$)
if (allocated(error)) return
call test_get_data(error, map, test_8_bits, test_${size_}$)
if (allocated(error)) return
call test_removal(error, map, test_8_bits, test_${size_}$)
if (allocated(error)) return
end subroutine
#:endfor
#:endfor
subroutine generate_vector(test_8_bits)
integer(int8), intent(out) :: test_8_bits(test_size, key_types)
integer :: index, key_type
real(dp) :: rand2(2)
integer(int32) :: rand_object(rand_size)
! Generate a unique int8 vector for each key type tested to avoid
! dupilcate keys and mapping conflicts.
do key_type = 1, key_types
do index=1, rand_size
call random_number(rand2)
if (rand2(1) < 0.5_dp) then
rand_object(index) = ceiling(-rand2(2)*hugep1, int32) - 1
else
rand_object(index) = floor(rand2(2)*hugep1, int32)
end if
end do
test_8_bits(:,key_type) = transfer( rand_object, 0_int8, test_size )
end do
end subroutine
subroutine test_input_random_data(error, map, test_8_bits, test_block)
type(error_type), allocatable, intent(out) :: error
type(chaining_hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: test_8_bits(test_size, key_types)
integer(int_index), intent(in) :: test_block
type(dummy_type) :: dummy_val
integer :: index2
type(key_type) :: key
logical :: conflict
do index2=1, test_size, test_block
! Test base int8 key interface
call set( key, test_8_bits( index2:index2+test_block-1, 1 ) )
call map % map_entry( key, dummy_val, conflict )
call check(error, .not.conflict, "Unable to map int8 entry because of a key conflict.")
! Test int32 key interface
! Use transfer to create int32 vector from generated int8 vector.
call set( key, transfer( test_8_bits( index2:index2+test_block-1, 2 ), [0_int32] ) )
call map % map_entry( key, dummy_val, conflict )
call check(error, .not.conflict, "Unable to map chaining int32 entry because of a key conflict.")
! Test int8 key generic interface
call map % map_entry( test_8_bits( index2:index2+test_block-1, 3 ), dummy_val, conflict )
call check(error, .not.conflict, "Unable to map chaining int8 generic interface")
! Test int32 key generic interface
call map % map_entry( transfer( test_8_bits( index2:index2+test_block-1, 4 ), [0_int32] ), dummy_val, conflict )
call check(error, .not.conflict, "Unable to map chaining int32 generic interface")
! Test char key generic interface
call map % map_entry( transfer( test_8_bits( index2:index2+test_block-1, 5 ), char_size ), dummy_val, conflict )
call check(error, .not.conflict, "Unable to map chaining character generic interface")
if (allocated(error)) return
end do
end subroutine
subroutine test_inquire_data(error, map, test_8_bits, test_block)
type(error_type), allocatable, intent(out) :: error
type(chaining_hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: test_8_bits(test_size, key_types)
integer(int_index), intent(in) :: test_block
integer :: index2
logical :: present
type(key_type) :: key
do index2=1, test_size, test_block
call set( key, test_8_bits( index2:index2+test_block-1, 1 ) )
call map % key_test( key, present )
call check(error, present, "Int8 KEY not found in map KEY_TEST.")
call set( key, transfer( test_8_bits( index2:index2+test_block-1, 2 ), [0_int32] ) )
call map % key_test( key, present )
call check(error, present, "Int32 KEY not found in map KEY_TEST.")
call map % key_test( test_8_bits( index2:index2+test_block-1, 3 ), present )
call check(error, present, "Int8 KEY generic interface not found in map KEY_TEST.")
call map % key_test( transfer( test_8_bits( index2:index2+test_block-1, 4 ), [0_int32] ), present )
call check(error, present, "Int32 KEY generic interface not found in map KEY_TEST.")
call map % key_test( transfer( test_8_bits( index2:index2+test_block-1, 5 ), char_size ), present )
call check(error, present, "Char KEY generic interface not found in map KEY_TEST.")
if (allocated(error)) return
end do
end subroutine
subroutine test_get_data(error, map, test_8_bits, test_block)
type(error_type), allocatable, intent(out) :: error
type(chaining_hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: test_8_bits(test_size, key_types)
integer(int_index), intent(in) :: test_block
integer :: index2
type(key_type) :: key
class(*), allocatable :: data
logical :: exists
do index2=1, test_size, test_block
call set( key, test_8_bits( index2:index2+test_block-1, 1 ) )
call map % get_other_data( key, data, exists )
call check(error, exists, "Unable to get data because int8 key not found in map.")
call set( key, transfer( test_8_bits( index2:index2+test_block-1, 2 ), [0_int32] ) )
call map % get_other_data( key, data, exists )
call check(error, exists, "Unable to get data because int32 key not found in map.")
call map % get_other_data( test_8_bits( index2:index2+test_block-1, 3 ), data, exists )
call check(error, exists, "Unable to get data because int8 generic interface key not found in map.")
call map % get_other_data( transfer( test_8_bits( index2:index2+test_block-1, 4 ), [0_int32] ) , data, exists )
call check(error, exists, "Unable to get data because int32 generic interface key not found in map.")
call map % get_other_data( transfer( test_8_bits( index2:index2+test_block-1, 5 ), char_size ) , data, exists )
call check(error, exists, "Unable to get data because character generic interface key not found in map.")
end do
end subroutine
subroutine test_removal(error, map, test_8_bits, test_block)
type(error_type), allocatable, intent(out) :: error
type(chaining_hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: test_8_bits(test_size, key_types)
integer(int_index), intent(in) :: test_block
type(key_type) :: key
integer(int_index) :: index2
logical :: existed
do index2=1, test_size, test_block
call set( key, test_8_bits( index2:index2+test_block-1, 1 ) )
call map % remove(key, existed)
call check(error, existed, "Int8 Key not found in entry removal.")
call set( key, transfer( test_8_bits( index2:index2+test_block-1, 2 ), [0_int32] ) )
call map % remove(key, existed)
call check(error, existed, "Int32 Key not found in entry removal.")
call map % remove(test_8_bits( index2:index2+test_block-1, 3 ), existed)
call check(error, existed, "Int8 Key generic interface not found in entry removal.")
call map % remove(transfer( test_8_bits( index2:index2+test_block-1, 4 ), [0_int32] ), existed)
call check(error, existed, "Int32 Key generic interface not found in entry removal.")
call map % remove(transfer( test_8_bits( index2:index2+test_block-1, 5 ), char_size ), existed)
call check(error, existed, "Character Key generic interface not found in entry removal.")
end do
end subroutine
subroutine test_removal_spec(error)
!! Test following code provided by @jannisteunissen
!! https://github.com/fortran-lang/stdlib/issues/785
type(error_type), allocatable, intent(out) :: error
type(chaining_hashmap_type) :: map
type(key_type) :: key
integer, parameter :: n_max = 500
integer :: n
integer, allocatable :: key_counts(:)
integer, allocatable :: seed(:)
integer(int8) :: int32_int8(4)
integer(int32) :: keys(n_max)
real(dp) :: r_uniform(n_max)
logical :: existed, present
call random_seed(size = n)
allocate(seed(n), source = 123456)
call random_seed(put = seed)
call random_number(r_uniform)
keys = nint(r_uniform * n_max * 0.25_dp)
call map%init(fnv_1_hasher, slots_bits=10)
do n = 1, n_max
call set(key, transfer(keys(n), int32_int8))
call map%key_test(key, present)
if (present) then
call map%remove(key, existed)
call check(error, existed, "chaining-removal-spec: Key not found in entry removal.")
return
else
call map%map_entry(key)
end if
end do
! Count number of keys that occur an odd number of times
allocate(key_counts(minval(keys):maxval(keys)), source = 0)
do n = 1, n_max
key_counts(keys(n)) = key_counts(keys(n)) + 1
end do
n = sum(iand(key_counts, 1))
call check(error, map%entries(), n, &
"chaining-removal-spec: Number of expected keys and entries are different.")
return
end subroutine
end module
module test_stdlib_open_maps
!! Test various aspects of the runtime system.
!! Running this program may require increasing the stack size to above 48 MBytes
!! or decreasing rand_power to 20 or less
use testdrive, only : new_unittest, unittest_type, error_type, check
use :: stdlib_kinds, only : dp, int8, int32
use stdlib_hashmaps, only : open_hashmap_type, int_depth, int_index
use stdlib_hashmap_wrappers
implicit none
private
type dummy_type
integer(int8), allocatable :: value(:)
end type dummy_type
integer(int32), parameter :: huge32 = huge(0_int32)
real(dp), parameter :: hugep1 = real(huge32, dp) + 1.0_dp
integer, parameter :: rand_power = 18
integer, parameter :: rand_size = 2**rand_power
integer, parameter :: test_size = rand_size*4
integer, parameter :: test_16 = 2**4
integer, parameter :: test_256 = 2**8
! key_type = 5 to support int8 and int32 key types tested. Can be
! increased to generate additional unique int8 vectors additional key types.
integer, parameter :: key_types = 5
character(len=16) :: char_size
public :: collect_stdlib_open_maps
contains
!> Collect all exported unit tests
subroutine collect_stdlib_open_maps(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("open-maps-fnv_1_hasher-16-byte-words", test_fnv_1_hasher_16_byte_words) &
#:for hash_ in HASH_NAME
#:for size_ in SIZE_NAME
, new_unittest("open-maps-${hash_}$-${size_}$-byte-words", test_${hash_}$_${size_}$_byte_words) &
#:endfor
#:endfor
, new_unittest("open-maps-removal-spec", test_removal_spec) &
]
end subroutine collect_stdlib_open_maps
#:for hash_ in HASH_NAME
#:for size_ in SIZE_NAME
subroutine test_${hash_}$_${size_}$_byte_words(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(open_hashmap_type) :: map
integer(int8) :: test_8_bits(test_size,key_types)
call generate_vector(test_8_bits)
call map % init( ${hash_}$, slots_bits=10 )
call test_input_random_data(error, map, test_8_bits, test_${size_}$)
if (allocated(error)) return
call test_inquire_data(error, map, test_8_bits, test_${size_}$)
if (allocated(error)) return
call test_get_data(error, map, test_8_bits, test_${size_}$)
if (allocated(error)) return
call test_removal(error, map, test_8_bits, test_${size_}$)
if (allocated(error)) return
end subroutine
#:endfor
#:endfor
subroutine generate_vector(test_8_bits)
integer(int8), intent(out) :: test_8_bits(test_size, key_types)
integer :: index, key_type
real(dp) :: rand2(2)
integer(int32) :: rand_object(rand_size)
! Generate a unique int8 vector for each key type tested to avoid
! dupilcate keys and mapping conflicts.
do key_type = 1, key_types
do index=1, rand_size
call random_number(rand2)
if (rand2(1) < 0.5_dp) then
rand_object(index) = ceiling(-rand2(2)*hugep1, int32) - 1
else
rand_object(index) = floor(rand2(2)*hugep1, int32)
end if
end do
test_8_bits(:,key_type) = transfer( rand_object, 0_int8, test_size )
enddo
end subroutine
subroutine test_input_random_data(error, map, test_8_bits, test_block)
type(error_type), allocatable, intent(out) :: error
type(open_hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: test_8_bits(test_size, key_types)
integer(int_index), intent(in) :: test_block
type(dummy_type) :: dummy_val
integer :: index2
type(key_type) :: key
logical :: conflict
do index2=1, test_size, test_block
! Test base int8 key interface
call set( key, test_8_bits( index2:index2+test_block-1, 1 ) )
call map % map_entry( key, dummy_val, conflict )
call check(error, .not.conflict, "Unable to map int8 entry because of a key conflict.")
! Test int32 key interface
! Use transfer to create int32 vector from generated int8 vector.
call set( key, transfer( test_8_bits( index2:index2+test_block-1, 2 ), [0_int32] ) )
call map % map_entry( key, dummy_val, conflict )
call check(error, .not.conflict, "Unable to map int32 entry because of a key conflict.")
! Test int8 generic key interface
call map % map_entry( test_8_bits( index2:index2+test_block-1, 3 ), dummy_val, conflict )
call check(error, .not.conflict, "Unable to map int8 generic key interface entry because of a key conflict.")
! Test int32 key generic interface
call map % map_entry( transfer( test_8_bits( index2:index2+test_block-1, 4 ), [0_int32] ), dummy_val, conflict )
call check(error, .not.conflict, "Unable to map open int32 generic key interface entry because of a key conflict.")
! Test character key generic interface
call map % map_entry( transfer( test_8_bits( index2:index2+test_block-1, 5 ), char_size ), dummy_val, conflict )
call check(error, .not.conflict, "Unable to map open character generic key interface entry because of a key conflict.")
if (allocated(error)) return
end do
end subroutine
subroutine test_inquire_data(error, map, test_8_bits, test_block)
type(error_type), allocatable, intent(out) :: error
type(open_hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: test_8_bits(test_size, key_types)
integer(int_index), intent(in) :: test_block
integer :: index2
logical :: present
type(key_type) :: key
do index2=1, test_size, test_block
call set( key, test_8_bits( index2:index2+test_block-1, 1 ) )
call map % key_test( key, present )
call check(error, present, "Int8 KEY not found in map KEY_TEST.")
call set( key, transfer( test_8_bits( index2:index2+test_block-1, 2 ), [0_int32] ) )
call map % key_test( key, present )
call check(error, present, "Int32 KEY not found in map KEY_TEST.")
call map % key_test( test_8_bits( index2:index2+test_block-1, 3 ), present )
call check(error, present, "Int8 KEY generic interface not found in map KEY_TEST.")
call map % key_test( transfer( test_8_bits( index2:index2+test_block-1, 4 ), [0_int32] ), present )
call check(error, present, "Int32 KEY generic interface not found in map KEY_TEST.")
call map % key_test( transfer( test_8_bits( index2:index2+test_block-1, 5 ), char_size ), present )
call check(error, present, "Character KEY generic interface not found in map KEY_TEST.")
if (allocated(error)) return
end do
end subroutine
subroutine test_get_data(error, map, test_8_bits, test_block)
type(error_type), allocatable, intent(out) :: error
type(open_hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: test_8_bits(test_size, key_types)
integer(int_index), intent(in) :: test_block
integer :: index2
type(key_type) :: key
class(*), allocatable :: data
logical :: exists
do index2=1, test_size, test_block
call set( key, test_8_bits( index2:index2+test_block-1, 1 ) )
call map % get_other_data( key, data, exists )
call check(error, exists, "Unable to get data because int8 key not found in map.")
call set( key, transfer( test_8_bits( index2:index2+test_block-1, 2 ), [0_int32] ) )
call map % get_other_data( key, data, exists )
call check(error, exists, "Unable to get data because int32 key not found in map.")
call map % get_other_data( test_8_bits( index2:index2+test_block-1, 3 ), data, exists )
call check(error, exists, "Unable to get data because int8 generic interface key not found in map.")
call map % get_other_data( transfer( test_8_bits( index2:index2+test_block-1, 4 ), [0_int32] ), data, exists )
call check(error, exists, "Unable to get data because int32 generic interface key not found in map.")
call map % get_other_data( transfer( test_8_bits( index2:index2+test_block-1, 5 ), char_size ), data, exists )
call check(error, exists, "Unable to get data because character generic interface key not found in map.")
end do
end subroutine
subroutine test_removal(error, map, test_8_bits, test_block)
type(error_type), allocatable, intent(out) :: error
type(open_hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: test_8_bits(test_size, key_types)
integer(int_index), intent(in) :: test_block
type(key_type) :: key
integer(int_index) :: index2
logical :: existed
do index2=1, test_size, test_block
call set( key, test_8_bits( index2:index2+test_block-1, 1 ) )
call map % remove(key, existed)
call check(error, existed, "Int8 Key not found in entry removal.")
call set( key, transfer( test_8_bits( index2:index2+test_block-1, 2 ), [0_int32] ) )
call map % remove(key, existed)
call check(error, existed, "Int32 Key not found in entry removal.")
call map % remove( test_8_bits( index2:index2+test_block-1, 3 ), existed)
call check(error, existed, "Int8 Key generic interface not found in entry removal.")
call map % remove(transfer( test_8_bits( index2:index2+test_block-1, 4 ), [0_int32] ), existed)
call check(error, existed, "Int32 Key generic interface not found in entry removal.")
call map % remove(transfer( test_8_bits( index2:index2+test_block-1, 5 ), char_size ), existed)
call check(error, existed, "Character Key generic interface not found in entry removal.")
end do
end subroutine
subroutine test_removal_spec(error)
!! Test following code provided by @jannisteunissen
!! https://github.com/fortran-lang/stdlib/issues/785
type(error_type), allocatable, intent(out) :: error
type(open_hashmap_type) :: map
type(key_type) :: key
integer, parameter :: n_max = 500
integer :: n
integer, allocatable :: key_counts(:)
integer, allocatable :: seed(:)
integer(int8) :: int32_int8(4)
integer(int32) :: keys(n_max)
real(dp) :: r_uniform(n_max)
logical :: existed, present
call random_seed(size = n)
allocate(seed(n), source = 123456)
call random_seed(put = seed)
call random_number(r_uniform)
keys = nint(r_uniform * n_max * 0.25_dp)
call map%init(fnv_1_hasher, slots_bits=10)
do n = 1, n_max
call set(key, transfer(keys(n), int32_int8))
call map%key_test(key, present)
if (present) then
call map%remove(key, existed)
call check(error, existed, "open-removal-spec: Key not found in entry removal.")
return
else
call map%map_entry(key)
end if
end do
! Count number of keys that occur an odd number of times
allocate(key_counts(minval(keys):maxval(keys)), source = 0)
do n = 1, n_max
key_counts(keys(n)) = key_counts(keys(n)) + 1
end do
n = sum(iand(key_counts, 1))
call check(error, map%entries(), n, &
"open-removal-spec: Number of expected keys and entries are different.")
return
end subroutine
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_stdlib_open_maps, only : collect_stdlib_open_maps
use test_stdlib_chaining_maps, only : collect_stdlib_chaining_maps
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("stdlib-open-maps", collect_stdlib_open_maps) &
, new_testsuite("stdlib-chaining-maps", collect_stdlib_chaining_maps) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/sorting/ 0000775 0001750 0001750 00000000000 15135654166 020632 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/sorting/CMakeLists.txt 0000664 0001750 0001750 00000000156 15135654166 023374 0 ustar alastair alastair set(
fppFiles
"test_sorting.fypp"
)
fypp_f90pp("${fyppFlags}" "${fppFiles}" outFiles)
ADDTESTPP(sorting)
fortran-lang-stdlib-0ede301/test/sorting/test_sorting.fypp 0000664 0001750 0001750 00000233744 15135654166 024273 0 ustar alastair alastair #include "macros.inc"
#:include "common.fypp"
#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_KINDS))
#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_KINDS))
#:set INT_INDEX_TYPES_ALT_NAME = list(zip(["int_index", "int_index_low"], ["integer(int_index)", "integer(int_index_low)"], ["default", "low"]))
module test_sorting
use, intrinsic :: iso_fortran_env, only: compiler_version, error_unit
use stdlib_kinds, only: int8, int16, int32, int64, dp, sp, xdp, qp
use stdlib_sorting, only: sort, sort_index, sort_adjoint, ord_sort, radix_sort, int_index, int_index_low
use stdlib_string_type, only: string_type, assignment(=), operator(>), &
operator(<), write(formatted)
#if STDLIB_BITSETS
use stdlib_bitsets, only: bitset_64, bitset_large, &
assignment(=), operator(>), operator(<)
#endif
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
integer(int32), parameter :: test_power = 16
integer(int32), parameter :: char_set_size = 16
integer(int32), parameter :: test_size = 2_int32**test_power
integer(int32), parameter :: char_size = char_set_size**4
integer(int32), parameter :: string_size = char_set_size**3
#if STDLIB_BITSETS
integer(int32), parameter :: bitset_size = char_set_size**3
#endif
integer(int32), parameter :: block_size = test_size/6
integer, parameter :: repeat = 1
integer(int32) :: &
blocks(0:test_size-1), &
decrease(0:test_size-1), &
identical(0:test_size-1), &
increase(0:test_size-1), &
rand0(0:test_size-1), &
rand1(0:test_size-1), &
rand2(0:test_size-1), &
rand3(0:test_size-1), &
rand10(0:test_size-1)
real(sp) :: rand_r32(0:test_size-1)
character(len=4) :: &
char_decrease(0:char_size-1), &
char_increase(0:char_size-1), &
char_rand(0:char_size-1)
type(string_type) :: &
string_decrease(0:string_size-1), &
string_increase(0:string_size-1), &
string_rand(0:string_size-1)
#if STDLIB_BITSETS
type(bitset_large) :: &
bitsetl_decrease(0:bitset_size-1), &
bitsetl_increase(0:bitset_size-1), &
bitsetl_rand(0:bitset_size-1)
type(bitset_64) :: &
bitset64_decrease(0:bitset_size-1), &
bitset64_increase(0:bitset_size-1), &
bitset64_rand(0:bitset_size-1)
#endif
integer(int32) :: dummy(0:test_size-1)
real(sp) :: real_dummy(0:test_size-1)
character(len=4) :: char_dummy(0:char_size-1)
type(string_type) :: string_dummy(0:string_size-1)
#if STDLIB_BITSETS
type(bitset_large) :: bitsetl_dummy(0:bitset_size-1)
type(bitset_64) :: bitset64_dummy(0:bitset_size-1)
#endif
integer(int_index) :: index_default(0:max(test_size, char_size, string_size)-1)
integer(int_index_low) :: index_low(0:max(test_size, char_size, string_size)-1)
integer(int32) :: work(0:test_size/2-1)
character(len=4) :: char_work(0:char_size/2-1)
type(string_type) :: string_work(0:string_size/2-1)
#if STDLIB_BITSETS
type(bitset_large) :: bitsetl_work(0:bitset_size/2-1)
type(bitset_64) :: bitset64_work(0:bitset_size/2-1)
#endif
integer(int_index) :: iwork_default(0:max(test_size, char_size, &
string_size)/2-1)
integer(int_index_low) :: iwork_low(0:max(test_size, char_size, &
string_size)/2-1)
integer :: count, i, index1, index2, j, k, l, temp
real(sp) :: arand, brand
character(*), parameter :: filename = 'test_sorting.txt'
integer :: lun
character(len=4) :: char_temp
type(string_type) :: string_temp
#if STDLIB_BITSETS
type(bitset_large) :: bitsetl_temp
type(bitset_64) :: bitset64_temp
#endif
logical :: ltest, ldummy
character(32) :: bin32
character(64) :: bin64
contains
!> Collect all exported unit tests
subroutine collect_sorting(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('char_ord_sorts', test_char_ord_sorts), &
new_unittest('string_ord_sorts', test_string_ord_sorts), &
#if STDLIB_BITSETS
new_unittest('bitset_large_ord_sorts', test_bitsetl_ord_sorts), &
new_unittest('bitset_64_ord_sorts', test_bitset64_ord_sorts), &
#endif
new_unittest('int_radix_sorts', test_int_radix_sorts), &
new_unittest('real_radix_sorts', test_real_radix_sorts), &
new_unittest('int_sorts', test_int_sorts), &
new_unittest('char_sorts', test_char_sorts), &
new_unittest('string_sorts', test_string_sorts), &
#if STDLIB_BITSETS
new_unittest('bitset_large_sorts', test_bitsetl_sorts), &
new_unittest('bitset_64_sorts', test_bitset64_sorts), &
#endif
#:for ki, ti, namei in INT_INDEX_TYPES_ALT_NAME
new_unittest('int_sort_indexes_${namei}$', test_int_sort_indexes_${namei}$), &
new_unittest('char_sort_indexes_${namei}$', test_char_sort_indexes_${namei}$), &
new_unittest('string_sort_indexes_${namei}$', test_string_sort_indexes_${namei}$), &
#if STDLIB_BITSETS
new_unittest('bitset_large_sort_indexes_${namei}$', test_bitsetl_sort_indexes_${namei}$), &
new_unittest('bitset_64_sort_indexes_${namei}$', test_bitset64_sort_indexes_${namei}$), &
#endif
#:endfor
#:for ki, ti, namei in INT_TYPES_ALT_NAME
new_unittest('int_sort_adjointes_${namei}$', test_int_sort_adjointes_${namei}$), &
new_unittest('char_sort_adjointes_${namei}$', test_char_sort_adjointes_${namei}$), &
new_unittest('string_sort_adjointes_${namei}$', test_string_sort_adjointes_${namei}$), &
#if STDLIB_BITSETS
new_unittest('bitset_large_sort_adjointes_${namei}$', test_bitsetl_sort_adjointes_${namei}$), &
new_unittest('bitset_64_sort_adjointes_${namei}$', test_bitset64_sort_adjointes_${namei}$), &
#endif
#:endfor
#:for ki, ti, namei in REAL_TYPES_ALT_NAME
new_unittest('real_sort_adjointes_${namei}$', test_real_sort_adjointes_${namei}$), &
#:endfor
new_unittest('int_ord_sorts', test_int_ord_sorts) &
]
end subroutine collect_sorting
subroutine initialize_tests()
! Create the test arrays
identical(:) = 10
do i=0, test_size-1
increase(i) = i
decrease(i) = test_size - 1 - i
call random_number( arand )
rand0(i) = int( floor( 4 * arand * test_size ), kind=int32 )
rand1(i) = int( floor( arand * test_size / 4 ), kind=int32 )
end do
blocks(:) = increase(:)
blocks(0:block_size-1) = increase(4*block_size:5*block_size-1)
blocks(block_size:2*block_size-1) = increase(0:block_size-1)
blocks(2*block_size:3*block_size-1) = increase(2*block_size:3*block_size-1)
blocks(3*block_size:4*block_size-1) = increase(block_size:2*block_size-1)
blocks(4*block_size:5*block_size-1) = increase(3*block_size:4*block_size-1)
rand2(:) = increase(:)
do i=0, test_size-1
call random_number( arand )
index1 = int( floor( arand * test_size ), kind=int32 )
temp = rand2(i)
rand2(i) = rand2(index1)
rand2(index1) = temp
end do
rand3(:) = increase(:)
do i=0, 2
call random_number( arand )
call random_number( brand )
index1 = int( floor( arand * test_size ), kind=int32 )
index2 = int( floor( brand * test_size ), kind=int32 )
temp = rand3(index1)
rand3(index1) = rand3(index2)
rand3(index2) = temp
end do
rand10(:) = increase(:)
do i=test_size-10, test_size-1
call random_number( arand )
rand10(i) = int( floor( arand * test_size ), kind=int32 )
end do
call random_number(rand_r32)
rand_r32 = rand_r32 - 0.5 ! to test both positive and negative numbers
count = 0
do i=0, char_set_size-1
do j=0, char_set_size-1
do k=0, char_set_size-1
do l=0, char_set_size-1
char_increase(count) = achar(97+i) // achar(97+j) // &
achar(97+k) // achar(97+l)
count = count + 1
end do
end do
end do
end do
do i=0, char_size-1
char_decrease(char_size-1-i) = char_increase(i)
end do
char_rand(:) = char_increase(:)
do i=0, char_size-1
call random_number( arand )
index1 = int( floor( arand * char_size ), kind=int32 )
char_temp = char_rand(i)
char_rand(i) = char_rand(index1)
char_rand(index1) = char_temp
end do
count = 0
do i=0, char_set_size-1
do j=0, char_set_size-1
do k=0, char_set_size-1
string_increase(count) = achar(97+i) // achar(97+j) // &
achar(97+k)
count = count + 1
end do
end do
end do
do i=0, string_size-1
string_decrease(string_size - 1 - i) = string_increase(i)
end do
string_rand(:) = string_increase(:)
do i=0, string_size-1
call random_number( arand )
index1 = int( floor( arand * string_size ), kind=int32 )
string_temp = string_rand(i)
string_rand(i) = string_rand(index1)
string_rand(index1) = string_temp
end do
#if STDLIB_BITSETS
do i = 0, bitset_size-1
write(bin32,'(b32.32)') i
call bitsetl_increase(i)%from_string(bin32)
end do
do i=0, bitset_size-1
bitsetl_decrease(bitset_size-1-i) = bitsetl_increase(i)
end do
bitsetl_rand(:) = bitsetl_increase(:)
do i=0, bitset_size-1
call random_number( arand )
index1 = int( floor( arand * bitset_size ), kind=int32 )
bitsetl_temp = bitsetl_rand(i)
bitsetl_rand(i) = bitsetl_rand(index1)
bitsetl_rand(index1) = bitsetl_temp
end do
do i = 0, bitset_size-1
write(bin64,'(b64.64)') i
call bitset64_increase(i)%from_string(bin64)
end do
do i=0, bitset_size-1
bitset64_decrease(bitset_size-1-i) = bitset64_increase(i)
end do
bitset64_rand(:) = bitset64_increase(:)
do i=0, bitset_size-1
call random_number( arand )
index1 = int( floor( arand * bitset_size ), kind=int32 )
bitset64_temp = bitset64_rand(i)
bitset64_rand(i) = bitset64_rand(index1)
bitset64_rand(index1) = bitset64_temp
end do
#endif
! Create and intialize file to report the results of the sortings
open( newunit=lun, file=filename, access='sequential', action='write', &
form='formatted', status='replace' )
write( lun, '(a)' ) trim(compiler_version())
write( lun, * )
write( lun, '("| Type | Elements | Array Name | Method ' // &
' | Time (s) |")' )
write( lun, '("|--------------|----------|-----------------|-----------' // &
'--|-----------|")' )
end subroutine initialize_tests
subroutine test_int_ord_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int64) :: i
integer, allocatable :: d1(:)
logical :: ltest
call test_int_ord_sort( blocks, "Blocks", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_ord_sort( decrease, "Decreasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_ord_sort( identical, "Identical", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_ord_sort( increase, "Increasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_ord_sort( rand1, "Random dense", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_ord_sort( rand2, "Random order", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_ord_sort( rand0, "Random sparse", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_ord_sort( rand3, "Random 3", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_ord_sort( rand10, "Random 10", ltest )
call check(error, ltest)
if (allocated(error)) return
!triggered an issue in insertion_sort
d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
call ord_sort( d1 )
call verify_sort( d1, ltest, i )
call check(error, ltest)
end subroutine test_int_ord_sorts
subroutine test_int_ord_sort( a, a_name, ltest )
integer(int32), intent(in) :: a(:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
dummy = a
call system_clock( t0, rate )
call ord_sort( dummy, work )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
end if
write( lun, '("| Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
test_size, a_name, "Ord_Sort", tdiff/rate
!reverse
dummy = a
call ord_sort( dummy, work, reverse = .true.)
call verify_reverse_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
"."
write(*,*) 'i = ', i
write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
end if
dummy = a
call ord_sort( dummy, reverse = .true.)
call verify_reverse_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
end if
end subroutine test_int_ord_sort
subroutine test_char_ord_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_char_ord_sort( char_decrease, "Char. Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_char_ord_sort( char_increase, "Char. Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_char_ord_sort( char_rand, "Char. Random", ltest )
call check(error, ltest)
end subroutine test_char_ord_sorts
subroutine test_char_ord_sort( a, a_name, ltest )
character(len=4), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
char_dummy = a
call system_clock( t0, rate )
call ord_sort( char_dummy, char_work )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_char_sort( char_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
end if
write( lun, '("| Character |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
char_size, a_name, "Ord_Sort", tdiff/rate
!reverse
char_dummy = a
call ord_sort( char_dummy, char_work, reverse = .true. )
call verify_char_reverse_sort( char_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
"."
write(*,*) 'i = ', i
write(*,'(a, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
end if
char_dummy = a
call ord_sort( char_dummy, reverse = .true. )
call verify_char_reverse_sort( char_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
"."
write(*,*) 'i = ', i
write(*,'(a, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
end if
end subroutine test_char_ord_sort
subroutine test_string_ord_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical:: ltest
call test_string_ord_sort( string_decrease, "String Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_string_ord_sort( string_increase, "String Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_string_ord_sort( string_rand, "String Random" , ltest)
call check(error, ltest)
end subroutine test_string_ord_sorts
subroutine test_string_ord_sort( a, a_name, ltest )
type(string_type), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
string_dummy = a
call system_clock( t0, rate )
call ord_sort( string_dummy, string_work )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_string_sort( string_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a, 2(1x,a))') 'string_dummy(i-1:i) = ', &
string_dummy(i-1:i)
end if
write( lun, '("| String_type |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
string_size, a_name, "Ord_Sort", tdiff/rate
!reverse
string_dummy = a
call ord_sort( string_dummy, string_work, reverse = .true. )
call verify_string_reverse_sort( string_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
"."
write(*,*) 'i = ', i
write(*,'(a, 2(1x,a))') 'string_dummy(i-1:i) = ', &
string_dummy(i-1:i)
end if
string_dummy = a
call ord_sort( string_dummy, reverse = .true. )
call verify_string_reverse_sort( string_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a, 2(1x,a))') 'string_dummy(i-1:i) = ', &
string_dummy(i-1:i)
end if
end subroutine test_string_ord_sort
#if STDLIB_BITSETS
subroutine test_bitsetl_ord_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical:: ltest
call test_bitsetl_ord_sort( bitsetl_decrease, "Bitset Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitsetl_ord_sort( bitsetl_increase, "Bitset Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitsetl_ord_sort( bitsetl_rand, "Bitset Random" , ltest)
call check(error, ltest)
end subroutine test_bitsetl_ord_sorts
subroutine test_bitsetl_ord_sort( a, a_name, ltest )
type(bitset_large), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
character(:), allocatable :: bin_im1, bin_i
ltest = .true.
tdiff = 0
do i = 1, repeat
bitsetl_dummy = a
call system_clock( t0, rate )
call ord_sort( bitsetl_dummy, bitsetl_work )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_bitsetl_sort( bitsetl_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitsetl_dummy(i-1)%to_string(bin_im1)
call bitsetl_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitsetl_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
write( lun, '("| Bitset_large |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
bitset_size, a_name, "Ord_Sort", tdiff/rate
!reverse
bitsetl_dummy = a
call ord_sort( bitsetl_dummy, bitsetl_work, reverse = .true. )
call verify_bitsetl_reverse_sort( bitsetl_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
"."
write(*,*) 'i = ', i
call bitsetl_dummy(i-1)%to_string(bin_im1)
call bitsetl_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitsetl_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
bitsetl_dummy = a
call ord_sort( bitsetl_dummy, reverse = .true. )
call verify_bitsetl_reverse_sort( bitsetl_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitsetl_dummy(i-1)%to_string(bin_im1)
call bitsetl_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitsetl_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
end subroutine test_bitsetl_ord_sort
subroutine test_bitset64_ord_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical:: ltest
call test_bitset64_ord_sort( bitset64_decrease, "Bitset Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitset64_ord_sort( bitset64_increase, "Bitset Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitset64_ord_sort( bitset64_rand, "Bitset Random" , ltest)
call check(error, ltest)
end subroutine test_bitset64_ord_sorts
subroutine test_bitset64_ord_sort( a, a_name, ltest )
type(bitset_64), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
character(:), allocatable :: bin_im1, bin_i
ltest = .true.
tdiff = 0
do i = 1, repeat
bitset64_dummy = a
call system_clock( t0, rate )
call ord_sort( bitset64_dummy, bitset64_work )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_bitset64_sort( bitset64_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitset64_dummy(i-1)%to_string(bin_im1)
call bitset64_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitset64_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
write( lun, '("| Bitset_64 |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
bitset_size, a_name, "Ord_Sort", tdiff/rate
!reverse
bitset64_dummy = a
call ord_sort( bitset64_dummy, bitset64_work, reverse = .true. )
call verify_bitset64_reverse_sort( bitset64_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
"."
write(*,*) 'i = ', i
call bitset64_dummy(i-1)%to_string(bin_im1)
call bitset64_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitset64_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
bitset64_dummy = a
call ord_sort( bitset64_dummy, reverse = .true. )
call verify_bitset64_reverse_sort( bitset64_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse ORD_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitset64_dummy(i-1)%to_string(bin_im1)
call bitset64_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitset64_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
end subroutine test_bitset64_ord_sort
#endif
subroutine test_int_radix_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int64) :: i
integer, allocatable :: d1(:)
logical :: ltest
call test_int_radix_sort( blocks, "Blocks", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_radix_sort( decrease, "Decreasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_radix_sort( identical, "Identical", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_radix_sort( increase, "Increasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_radix_sort( rand1, "Random dense", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_radix_sort( rand2, "Random order", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_radix_sort( rand0, "Random sparse", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_radix_sort( rand3, "Random 3", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_radix_sort( rand10, "Random 10", ltest )
call check(error, ltest)
if (allocated(error)) return
!triggered an issue in insertion
d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
call sort( d1 )
call verify_sort( d1, ltest, i )
call check(error, ltest)
end subroutine test_int_radix_sorts
subroutine test_int_radix_sort( a, a_name, ltest )
integer(int32), intent(in) :: a(:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
dummy = a
call system_clock( t0, rate )
call radix_sort( dummy )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "RADIX_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
end if
write( lun, '("| Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
test_size, a_name, "Radix_Sort", tdiff/rate
! reverse
dummy = a
call radix_sort( dummy, reverse = .true.)
call verify_reverse_sort(dummy, valid, i)
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse RADIX_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
end if
end subroutine test_int_radix_sort
subroutine test_real_radix_sort( a, a_name, ltest )
real(sp), intent(in) :: a(:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
real_dummy = a
call system_clock( t0, rate )
call radix_sort( real_dummy )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_real_sort( real_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "RADIX_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a12, 2f12.5)') 'real_dummy(i-1:i) = ', real_dummy(i-1:i)
end if
write( lun, '("| Real |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
test_size, a_name, "Radix_Sort", tdiff/rate
! reverse
real_dummy = a
call radix_sort( real_dummy, reverse = .true.)
call verify_real_reverse_sort(real_dummy, valid, i)
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse RADIX_SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a12, 2f12.5)') 'real_dummy(i-1:i) = ', real_dummy(i-1:i)
end if
end subroutine test_real_radix_sort
subroutine test_real_radix_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_real_radix_sort( rand_r32, "rand-real32", ltest )
call check(error, ltest)
if (allocated(error)) return
end subroutine test_real_radix_sorts
subroutine test_int_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int64) :: i
integer, allocatable :: d1(:)
logical :: ltest
call test_int_sort( blocks, "Blocks", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort( decrease, "Decreasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort( identical, "Identical", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort( increase, "Increasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort( rand1, "Random dense", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort( rand2, "Random order", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort( rand0, "Random sparse", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort( rand3, "Random 3", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort( rand10, "Random 10", ltest )
call check(error, ltest)
if (allocated(error)) return
!triggered an issue in insertion
d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
call sort( d1 )
call verify_sort( d1, ltest, i )
call check(error, ltest)
end subroutine test_int_sorts
subroutine test_int_sort( a, a_name, ltest )
integer(int32), intent(in) :: a(:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
dummy = a
call system_clock( t0, rate )
call sort( dummy )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
end if
write( lun, '("| Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
test_size, a_name, "Sort", tdiff/rate
! reverse
dummy = a
call sort( dummy, .true.)
call verify_reverse_sort(dummy, valid, i)
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
end if
end subroutine test_int_sort
subroutine test_char_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_char_sort( char_decrease, "Char. Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_char_sort( char_increase, "Char. Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_char_sort( char_rand, "Char. Random", ltest )
call check(error, ltest)
end subroutine test_char_sorts
subroutine test_char_sort( a, a_name, ltest )
character(len=4), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
char_dummy = a
call system_clock( t0, rate )
call sort( char_dummy )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_char_sort( char_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a17, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
end if
write( lun, '("| Character |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
char_size, a_name, "Sort", tdiff/rate
!reverse
char_dummy = a
call sort( char_dummy, .true.)
call verify_char_reverse_sort( char_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a17, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
end if
end subroutine test_char_sort
subroutine test_string_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_string_sort( string_decrease, "String Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_string_sort( string_increase, "String Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_string_sort( string_rand, "String Random", ltest )
call check(error, ltest)
end subroutine test_string_sorts
subroutine test_string_sort( a, a_name, ltest )
type(string_type), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
string_dummy = a
call system_clock( t0, rate )
call sort( string_dummy )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_string_sort( string_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a17, 2(1x,a4))') 'string_dummy(i-1:i) = ', &
string_dummy(i-1:i)
end if
write( lun, '("| String_type |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
string_size, a_name, "Sort", tdiff/rate
! reverse
string_dummy = a
call sort( string_dummy, .true.)
call verify_string_reverse_sort(string_dummy, valid, i)
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a17, 2(1x,a4))') 'string_dummy(i-1:i) = ', &
string_dummy(i-1:i)
end if
end subroutine test_string_sort
#if STDLIB_BITSETS
subroutine test_bitsetl_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_bitsetl_sort( bitsetl_decrease, "Bitset Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitsetl_sort( bitsetl_increase, "Bitset Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitsetl_sort( bitsetl_rand, "Bitset Random", ltest )
call check(error, ltest)
end subroutine test_bitsetl_sorts
subroutine test_bitsetl_sort( a, a_name, ltest )
type(bitset_large), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
character(:), allocatable :: bin_im1, bin_i
ltest = .true.
tdiff = 0
do i = 1, repeat
bitsetl_dummy = a
call system_clock( t0, rate )
call sort( bitsetl_dummy )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_bitsetl_sort( bitsetl_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitsetl_dummy(i-1)%to_string(bin_im1)
call bitsetl_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitsetl_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
write( lun, '("| Bitset_large |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
bitset_size, a_name, "Sort", tdiff/rate
! reverse
bitsetl_dummy = a
call sort( bitsetl_dummy, .true.)
call verify_bitsetl_reverse_sort(bitsetl_dummy, valid, i)
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitsetl_dummy(i-1)%to_string(bin_im1)
call bitsetl_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitsetl_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
end subroutine test_bitsetl_sort
subroutine test_bitset64_sorts(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_bitset64_sort( bitset64_decrease, "Bitset Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitset64_sort( bitset64_increase, "Bitset Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitset64_sort( bitset64_rand, "Bitset Random", ltest )
call check(error, ltest)
end subroutine test_bitset64_sorts
subroutine test_bitset64_sort( a, a_name, ltest )
type(bitset_64), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
character(:), allocatable :: bin_im1, bin_i
ltest = .true.
tdiff = 0
do i = 1, repeat
bitset64_dummy = a
call system_clock( t0, rate )
call sort( bitset64_dummy )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_bitset64_sort( bitset64_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitset64_dummy(i-1)%to_string(bin_im1)
call bitset64_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitset64_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
write( lun, '("| Bitset_64 |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
bitset_size, a_name, "Sort", tdiff/rate
! reverse
bitset64_dummy = a
call sort( bitset64_dummy, .true.)
call verify_bitset64_reverse_sort(bitset64_dummy, valid, i)
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "reverse SORT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitset64_dummy(i-1)%to_string(bin_im1)
call bitset64_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitsetl_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
end subroutine test_bitset64_sort
#endif
#:for ki, ti, namei in INT_INDEX_TYPES_ALT_NAME
subroutine test_int_sort_indexes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int64) :: i
integer(int32), allocatable :: d1(:)
${ti}$, allocatable :: index(:)
logical :: ltest
call test_int_sort_index_${namei}$( blocks, "Blocks", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_index_${namei}$( decrease, "Decreasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_index_${namei}$( identical, "Identical", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_index_${namei}$( increase, "Increasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_index_${namei}$( rand1, "Random dense", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_index_${namei}$( rand2, "Random order", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_index_${namei}$( rand0, "Random sparse", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_index_${namei}$( rand3, "Random 3", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_index_${namei}$( rand10, "Random 10", ltest )
call check(error, ltest)
if (allocated(error)) return
d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
allocate( index(size(d1)) )
call sort_index( d1, index )
call verify_sort( d1, ltest, i )
call check(error, ltest)
end subroutine test_int_sort_indexes_${namei}$
subroutine test_int_sort_index_${namei}$( a, a_name, ltest )
integer(int32), intent(inout) :: a(:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
dummy = a
call system_clock( t0, rate )
call sort_index( dummy, index_${namei}$, work, iwork_${namei}$ )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
dummy = a(index_${namei}$(0:size(a)-1))
call verify_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_INDEX did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a18, 2i7)') 'a(index_${namei}$(i-1:i)) = ', a(index_${namei}$(i-1:i))
end if
write( lun, '("| Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
test_size, a_name, "Sort_Index", tdiff/rate
dummy = a
call sort_index( dummy, index_${namei}$, work, iwork_${namei}$, reverse=.true. )
dummy = a(index_${namei}$(size(a)-1))
call verify_reverse_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_INDEX did not reverse sort " // &
a_name // "."
write(*,*) 'i = ', i
write(*,'(a18, 2i7)') 'a(index_${namei}$(i-1:i)) = ', a(index_${namei}$(i-1:i))
end if
end subroutine test_int_sort_index_${namei}$
subroutine test_char_sort_indexes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_char_sort_index_${namei}$( char_decrease, "Char. Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_char_sort_index_${namei}$( char_increase, "Char. Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_char_sort_index_${namei}$( char_rand, "Char. Random", ltest )
call check(error, ltest)
end subroutine test_char_sort_indexes_${namei}$
subroutine test_char_sort_index_${namei}$( a, a_name, ltest )
character(len=4), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
char_dummy = a
call system_clock( t0, rate )
call sort_index( char_dummy, index_${namei}$, char_work, iwork_${namei}$ )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_char_sort( char_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_INDEX did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a17, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
end if
write( lun, '("| Character |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
char_size, a_name, "Sort_Index", tdiff/rate
end subroutine test_char_sort_index_${namei}$
subroutine test_string_sort_indexes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_string_sort_index_${namei}$( string_decrease, "String Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_string_sort_index_${namei}$( string_increase, "String Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_string_sort_index_${namei}$( string_rand, "String Random", ltest )
call check(error, ltest)
end subroutine test_string_sort_indexes_${namei}$
subroutine test_string_sort_index_${namei}$( a, a_name, ltest )
type(string_type), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
string_dummy = a
call system_clock( t0, rate )
call sort_index( string_dummy, index_${namei}$, string_work, iwork_${namei}$ )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_string_sort( string_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_INDEX did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a17, 2(1x,a4))') 'string_dummy(i-1:i) = ', &
string_dummy(i-1:i)
end if
write( lun, '("| String_type |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
string_size, a_name, "Sort_Index", tdiff/rate
end subroutine test_string_sort_index_${namei}$
#if STDLIB_BITSETS
subroutine test_bitsetl_sort_indexes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_bitsetl_sort_index_${namei}$( bitsetl_decrease, "Bitset Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitsetl_sort_index_${namei}$( bitsetl_increase, "Bitset Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitsetl_sort_index_${namei}$( bitsetl_rand, "Bitset Random", ltest )
call check(error, ltest)
end subroutine test_bitsetl_sort_indexes_${namei}$
subroutine test_bitsetl_sort_index_${namei}$( a, a_name, ltest )
type(bitset_large), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
character(:), allocatable :: bin_im1, bin_i
ltest = .true.
tdiff = 0
do i = 1, repeat
bitsetl_dummy = a
call system_clock( t0, rate )
call sort_index( bitsetl_dummy, index_${namei}$, bitsetl_work, iwork_${namei}$ )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_bitsetl_sort( bitsetl_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_INDEX did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitsetl_dummy(i-1)%to_string(bin_im1)
call bitsetl_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitsetl_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
write( lun, '("| Bitset_large |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
bitset_size, a_name, "Sort_Index", tdiff/rate
end subroutine test_bitsetl_sort_index_${namei}$
subroutine test_bitset64_sort_indexes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_bitset64_sort_index_${namei}$( bitset64_decrease, "Bitset Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitset64_sort_index_${namei}$( bitset64_increase, "Bitset Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitset64_sort_index_${namei}$( bitset64_rand, "Bitset Random", ltest )
call check(error, ltest)
end subroutine test_bitset64_sort_indexes_${namei}$
subroutine test_bitset64_sort_index_${namei}$( a, a_name, ltest )
type(bitset_64), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i
logical :: valid
character(:), allocatable :: bin_im1, bin_i
ltest = .true.
tdiff = 0
do i = 1, repeat
bitset64_dummy = a
call system_clock( t0, rate )
call sort_index( bitset64_dummy, index_${namei}$, bitset64_work, iwork_${namei}$ )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_bitset64_sort( bitset64_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_INDEX did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitset64_dummy(i-1)%to_string(bin_im1)
call bitset64_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitset64_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
write( lun, '("| Bitset_64 |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
bitset_size, a_name, "Sort_Index", tdiff/rate
end subroutine test_bitset64_sort_index_${namei}$
#endif
#:endfor
#:for ki, ti, namei in INT_TYPES_ALT_NAME
subroutine test_int_sort_adjointes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int64) :: i
integer(int32), allocatable :: d1(:)
${ti}$, allocatable :: adjoint(:)
logical :: ltest
call test_int_sort_adjoint_${namei}$( blocks, "Blocks", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_adjoint_${namei}$( decrease, "Decreasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_adjoint_${namei}$( identical, "Identical", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_adjoint_${namei}$( increase, "Increasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_adjoint_${namei}$( rand1, "Random dense", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_adjoint_${namei}$( rand2, "Random order", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_adjoint_${namei}$( rand0, "Random sparse", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_adjoint_${namei}$( rand3, "Random 3", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_int_sort_adjoint_${namei}$( rand10, "Random 10", ltest )
call check(error, ltest)
if (allocated(error)) return
d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
allocate( adjoint(size(d1)))
adjoint = int([(i, i=1, size(d1))], kind=${namei}$)
call sort_adjoint( d1, adjoint )
call verify_sort( d1, ltest, i )
call check(error, ltest)
end subroutine test_int_sort_adjointes_${namei}$
subroutine test_int_sort_adjoint_${namei}$( a, a_name, ltest )
integer(int32), intent(inout) :: a(:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
${ti}$ :: adjoint(size(a))
${ti}$ :: iwork(size(a))
integer(int64) :: i, j
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
dummy = a
adjoint = int([(j, j=1_int64, size(a, kind=int64))], kind=${namei}$)
call system_clock( t0, rate )
call sort_adjoint( dummy, adjoint, work, iwork )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a18, 2i7)') 'a(i-1:i) = ', a(i-1:i)
end if
write( lun, '("| Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
test_size, a_name, "Sort_adjoint", tdiff/rate
!reverse
dummy = a
adjoint = int([(j, j=1_int64, size(a, kind=int64))], kind=${namei}$)
call sort_adjoint( dummy, adjoint, work, iwork, reverse=.true. )
call verify_reverse_sort( dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_ADJOINT did not reverse sort " // &
a_name // "."
write(*,*) 'i = ', i
write(*,'(a18, 2i7)') 'a(i-1:i) = ', a(i-1:i)
end if
end subroutine test_int_sort_adjoint_${namei}$
subroutine test_char_sort_adjointes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_char_sort_adjoint_${namei}$( char_decrease, "Char. Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_char_sort_adjoint_${namei}$( char_increase, "Char. Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_char_sort_adjoint_${namei}$( char_rand, "Char. Random", ltest )
call check(error, ltest)
end subroutine test_char_sort_adjointes_${namei}$
subroutine test_char_sort_adjoint_${namei}$( a, a_name, ltest )
character(len=4), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
${ti}$ :: adjoint(size(a))
${ti}$ :: iwork(size(a))
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i, j
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
char_dummy = a
adjoint = int([(j, j=1_int64, size(a, kind=int64))], kind=${namei}$)
call system_clock( t0, rate )
call sort_adjoint( char_dummy, adjoint, char_work, iwork )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_char_sort( char_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_ADJ did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a17, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
end if
write( lun, '("| Character |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
char_size, a_name, "Sort_adjoint", tdiff/rate
end subroutine test_char_sort_adjoint_${namei}$
subroutine test_string_sort_adjointes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_string_sort_adjoint_${namei}$( string_decrease, "String Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_string_sort_adjoint_${namei}$( string_increase, "String Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_string_sort_adjoint_${namei}$( string_rand, "String Random", ltest )
call check(error, ltest)
end subroutine test_string_sort_adjointes_${namei}$
subroutine test_string_sort_adjoint_${namei}$( a, a_name, ltest )
type(string_type), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
${ti}$ :: adjoint(size(a))
${ti}$ :: iwork(size(a))
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i, j
logical :: valid
ltest = .true.
tdiff = 0
do i = 1, repeat
string_dummy = a
adjoint = int([(j, j=1_int64, size(a, kind=int64))], kind=${namei}$)
call system_clock( t0, rate )
call sort_adjoint( string_dummy, adjoint, string_work, iwork )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_string_sort( string_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a17, 2(1x,a4))') 'string_dummy(i-1:i) = ', &
string_dummy(i-1:i)
end if
write( lun, '("| String_type |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
string_size, a_name, "Sort_adjoint", tdiff/rate
end subroutine test_string_sort_adjoint_${namei}$
#if STDLIB_BITSETS
subroutine test_bitsetl_sort_adjointes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_bitsetl_sort_adjoint_${namei}$( bitsetl_decrease, "Bitset Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitsetl_sort_adjoint_${namei}$( bitsetl_increase, "Bitset Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitsetl_sort_adjoint_${namei}$( bitsetl_rand, "Bitset Random", ltest )
call check(error, ltest)
end subroutine test_bitsetl_sort_adjointes_${namei}$
subroutine test_bitsetl_sort_adjoint_${namei}$( a, a_name, ltest )
type(bitset_large), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
${ti}$ :: adjoint(size(a))
${ti}$ :: iwork(size(a))
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i, j
logical :: valid
character(:), allocatable :: bin_im1, bin_i
ltest = .true.
tdiff = 0
do i = 1, repeat
bitsetl_dummy = a
adjoint = int([(j, j=1_int64, size(a, kind=int64))], kind=${namei}$)
call system_clock( t0, rate )
call sort_adjoint( bitsetl_dummy, adjoint, bitsetl_work, iwork )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_bitsetl_sort( bitsetl_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitsetl_dummy(i-1)%to_string(bin_im1)
call bitsetl_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitsetl_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
write( lun, '("| Bitset_large |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
bitset_size, a_name, "Sort_adjoint", tdiff/rate
end subroutine test_bitsetl_sort_adjoint_${namei}$
subroutine test_bitset64_sort_adjointes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_bitset64_sort_adjoint_${namei}$( bitset64_decrease, "Bitset Decrease", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitset64_sort_adjoint_${namei}$( bitset64_increase, "Bitset Increase", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_bitset64_sort_adjoint_${namei}$( bitset64_rand, "Bitset Random", ltest )
call check(error, ltest)
end subroutine test_bitset64_sort_adjointes_${namei}$
subroutine test_bitset64_sort_adjoint_${namei}$( a, a_name, ltest )
type(bitset_64), intent(in) :: a(0:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
${ti}$ :: adjoint(size(a))
${ti}$ :: iwork(size(a))
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
integer(int64) :: i, j
logical :: valid
character(:), allocatable :: bin_im1, bin_i
ltest = .true.
tdiff = 0
do i = 1, repeat
bitset64_dummy = a
adjoint = int([(j, j=1_int64, size(a, kind=int64))], kind=${namei}$)
call system_clock( t0, rate )
call sort_adjoint( bitset64_dummy, adjoint, bitset64_work, iwork )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_bitset64_sort( bitset64_dummy, valid, i )
ltest = (ltest .and. valid)
if ( .not. valid ) then
write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
write(*,*) 'i = ', i
call bitset64_dummy(i-1)%to_string(bin_im1)
call bitset64_dummy(i)%to_string(bin_i)
write(*,'(a, 2(a:,1x))') 'bitset64_dummy(i-1:i) = ', &
bin_im1, bin_i
end if
write( lun, '("| Bitset_64 |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
bitset_size, a_name, "Sort_adjoint", tdiff/rate
end subroutine test_bitset64_sort_adjoint_${namei}$
#endif
#:endfor
#:for ki, ti, namei in REAL_TYPES_ALT_NAME
subroutine test_real_sort_adjointes_${namei}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical :: ltest
call test_real_sort_adjoint_${namei}$( blocks, "Blocks", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_real_sort_adjoint_${namei}$( decrease, "Decreasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_real_sort_adjoint_${namei}$( identical, "Identical", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_real_sort_adjoint_${namei}$( increase, "Increasing", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_real_sort_adjoint_${namei}$( rand1, "Random dense", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_real_sort_adjoint_${namei}$( rand2, "Random order", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_real_sort_adjoint_${namei}$( rand0, "Random sparse", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_real_sort_adjoint_${namei}$( rand3, "Random 3", ltest )
call check(error, ltest)
if (allocated(error)) return
call test_real_sort_adjoint_${namei}$( rand10, "Random 10", ltest )
call check(error, ltest)
if (allocated(error)) return
end subroutine test_real_sort_adjointes_${namei}$
subroutine test_real_sort_adjoint_${namei}$( a, a_name, ltest )
integer(int32), intent(inout) :: a(:)
character(*), intent(in) :: a_name
logical, intent(out) :: ltest
integer(int64) :: t0, t1, tdiff
real(dp) :: rate
${ti}$ :: adjoint(size(a))
${ti}$ :: iwork(size(a))
integer(int64) :: i, j
integer(int64) :: i_adj
logical :: valid
logical :: valid_adj
ltest = .true.
tdiff = 0
do i = 1, repeat
dummy = a
adjoint = real(dummy, kind=${namei}$)
call system_clock( t0, rate )
call sort_adjoint( dummy, adjoint, work, iwork )
call system_clock( t1, rate )
tdiff = tdiff + t1 - t0
end do
tdiff = tdiff/repeat
call verify_sort( dummy, valid, i )
call verify_adjoint(int(adjoint, kind=int32), dummy, valid_adj, i_adj )
ltest = (ltest .and. valid .and. valid_adj)
if ( .not. valid ) then
write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
write(*,*) 'i = ', i
write(*,'(a18, 2i7)') 'a(i-1:i) = ', a(i-1:i)
end if
if ( .not. valid_adj ) then
write( *, * ) "SORT_ADJOINT did not sort " // a_name // "."
write(*,*) 'i_adj = ', i_adj
write(*,'(a18, 2i7)') 'a(i_adj-1:i_adj) = ', a(i_adj-1:i_adj)
end if
write( lun, '("| Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
'a12, " |", F10.6, " |" )' ) &
test_size, a_name, "Sort_adjoint", tdiff/rate
!reverse
dummy = a
adjoint = real(dummy, kind=${namei}$)
call sort_adjoint( dummy, adjoint, work, iwork, reverse=.true. )
call verify_reverse_sort( dummy, valid, i )
call verify_adjoint(int(adjoint, kind=int32), dummy, valid_adj, i_adj )
ltest = (ltest .and. valid .and. valid_adj)
if ( .not. valid ) then
write( *, * ) "SORT_ADJOINT did not reverse sort " // &
a_name // "."
write(*,*) 'i = ', i
write(*,'(a18, 2i7)') 'a(i-1:i) = ', a(i-1:i)
end if
if ( .not. valid_adj ) then
write( *, * ) "SORT_ADJOINT did not reverse sort " // &
a_name // "."
write(*,*) 'i_adj = ', i_adj
write(*,'(a18, 2i7)') 'a(i_adj-1:i_adj) = ', a(i_adj-1:i_adj)
end if
end subroutine test_real_sort_adjoint_${namei}$
#:endfor
subroutine verify_sort( a, valid, i )
integer(int32), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) > a(i) ) return
end do
valid = .true.
end subroutine verify_sort
subroutine verify_adjoint( a, true, valid, i )
integer(int32), intent(in) :: a(:)
integer(int32), intent(in) :: true(:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n
if ( a(i) /= true(i) ) return
end do
valid = .true.
end subroutine verify_adjoint
subroutine verify_real_sort( a, valid, i )
real(sp), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) > a(i) ) return
end do
valid = .true.
end subroutine verify_real_sort
subroutine verify_string_sort( a, valid, i )
type(string_type), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) > a(i) ) return
end do
valid = .true.
end subroutine verify_string_sort
#if STDLIB_BITSETS
subroutine verify_bitsetl_sort( a, valid, i )
type(bitset_large), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) > a(i) ) return
end do
valid = .true.
end subroutine verify_bitsetl_sort
subroutine verify_bitset64_sort( a, valid, i )
type(bitset_64), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) > a(i) ) return
end do
valid = .true.
end subroutine verify_bitset64_sort
#endif
subroutine verify_char_sort( a, valid, i )
character(len=4), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) > a(i) ) return
end do
valid = .true.
end subroutine verify_char_sort
subroutine verify_char_reverse_sort( a, valid, i )
character(len=4), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) < a(i) ) return
end do
valid = .true.
end subroutine verify_char_reverse_sort
subroutine verify_reverse_sort( a, valid, i )
integer(int32), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) < a(i) ) return
end do
valid = .true.
end subroutine verify_reverse_sort
subroutine verify_real_reverse_sort( a, valid, i )
real(sp), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) < a(i) ) return
end do
valid = .true.
end subroutine verify_real_reverse_sort
subroutine verify_string_reverse_sort( a, valid, i )
type(string_type), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) < a(i) ) return
end do
valid = .true.
end subroutine verify_string_reverse_sort
#if STDLIB_BITSETS
subroutine verify_bitsetl_reverse_sort( a, valid, i )
type(bitset_large), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) < a(i) ) return
end do
valid = .true.
end subroutine verify_bitsetl_reverse_sort
subroutine verify_bitset64_reverse_sort( a, valid, i )
type(bitset_64), intent(in) :: a(0:)
logical, intent(out) :: valid
integer(int64), intent(out) :: i
integer(int64) :: n
n = size( a, kind=int64 )
valid = .false.
do i=1, n-1
if ( a(i-1) < a(i) ) return
end do
valid = .true.
end subroutine verify_bitset64_reverse_sort
#endif
end module test_sorting
program tester
use, intrinsic :: iso_fortran_env, only: compiler_version, error_unit
use testdrive, only: new_testsuite, run_testsuite, testsuite_type
use test_sorting, only: initialize_tests, collect_sorting
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
call initialize_tests()
stat = 0
testsuites = [ &
new_testsuite("sorting", collect_sorting) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/hash_functions_perf/ 0000775 0001750 0001750 00000000000 15135654166 023174 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/hash_functions_perf/CMakeLists.txt 0000775 0001750 0001750 00000000453 15135654166 025741 0 ustar alastair alastair ADDTEST(32_bit_hash_performance)
ADDTEST(64_bit_hash_performance)
if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU AND CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 10.0)
target_compile_options(
test_64_bit_hash_performance
PRIVATE
$<$:-fno-range-check>
)
endif()
fortran-lang-stdlib-0ede301/test/hash_functions_perf/test_64_bit_hash_performance.f90 0000775 0001750 0001750 00000012443 15135654166 031235 0 ustar alastair alastair program test_64_bit_hash_performance
!! Program to compare the relative performance of different 64 bit hash
!! functions
use stdlib_kinds, only: &
dp, &
int8, &
int32, &
int64
use stdlib_hash_64bit
implicit none
integer, parameter :: &
block_size(8) = [ 1, 2, 4, 8, 16, 64, 256, 1024 ]
integer(int32), parameter :: huge32 = huge(0_int32)
real(dp), parameter :: hugep1 = real(huge32, dp) + 1.0_dp
integer, parameter :: rand_power = 16
integer, parameter :: rand_size = 2**rand_power
integer, parameter :: test_size = rand_size * 4
integer, parameter :: repeat = 4
integer :: index, k
integer :: lun
real(dp) :: rand(2)
integer(int32) :: rand_object(rand_size)
integer(int8) :: test_object(test_size)
open( newunit=lun, file="64_bit_hash_performance_log.txt", &
access="sequential", action="write", form="formatted", &
position="rewind" )
do index=1, rand_size
call random_number(rand)
if (rand(1) < 0.5_dp) then
rand_object(index) = ceiling(-rand(2)*hugep1, int32) - 1
else
rand_object(index) = floor(rand(2)*hugep1, int32)
end if
end do
test_object(:) = transfer( rand_object, 0_int8, test_size )
write(lun, '("| Algorithm | Key Size | Key # | Time (s) |")')
write(lun, '("| | Bytes | | |")')
write(lun, '("|------------|-----------|------------|----------|")')
call test_fnv_1()
call test_fnv_1a()
call test_pengy()
call test_spooky()
contains
subroutine test_fnv_1()
integer :: index2
integer(int64) :: hash
real :: t1, t2, tdiff
integer(int64) :: summary(repeat)
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = fnv_1_hash( test_object( index2: &
index2+block_size(k)-1 ) )
if (index2 == index) summary(index) = hash
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'FNV-1', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_fnv_1
subroutine test_fnv_1a()
integer :: index2
integer(int64) :: hash
real :: t1, t2, tdiff
integer(int64) :: summary(repeat)
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = fnv_1a_hash( test_object( index2: &
index2+block_size(k)-1 ) )
if (index2 == index) summary(index) = hash
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'FNV-1a', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_fnv_1a
subroutine test_spooky()
integer :: index2
integer(int64) :: hash(2)
integer(int64) :: seed(2) = [ 0_int64, 0_int64 ]
real :: t1, t2, tdiff
integer(int64) :: summary(repeat)
call new_spooky_hash_seed( seed )
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = spooky_hash( test_object( index2: &
index2+block_size(k)-1 ), &
seed )
if (index2 == index) summary(index) = hash(1)
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'Spooky', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_spooky
subroutine test_pengy()
integer :: index2
integer(int64) :: hash
integer(int32) :: seed = int( z'DEADBEEF', int32 )
real :: t1, t2, tdiff
integer(int64) :: summary(repeat)
call new_pengy_hash_seed( seed )
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = pengy_hash( test_object( index2: &
index2+block_size(k)-1 ), &
seed )
if (index2 == index) summary(index) = hash
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'Pengy', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_pengy
end program test_64_bit_hash_performance
fortran-lang-stdlib-0ede301/test/hash_functions_perf/test_32_bit_hash_performance.f90 0000775 0001750 0001750 00000014502 15135654166 031226 0 ustar alastair alastair program test_32_bit_hash_performance
!! Program to compare the relative performance of different 32 bit hash
!! functions
use stdlib_kinds, only: &
dp, &
int8, &
int32, &
int64
use stdlib_hash_32bit
implicit none
integer, parameter :: &
block_size(8) = [ 1, 2, 4, 8, 16, 64, 256, 1024 ]
integer(int32), parameter :: huge32 = huge(0_int32)
real(dp), parameter :: hugep1 = real(huge32, dp) + 1.0_dp
integer, parameter :: rand_power = 16
integer, parameter :: rand_size = 2**rand_power
integer, parameter :: test_size = rand_size * 4
integer, parameter :: repeat = 4
integer :: index, k
integer :: lun
real(dp) :: rand(2)
integer(int32) :: rand_object(rand_size)
integer(int8) :: test_object(test_size)
open( newunit=lun, file="32_bit_hash_performance_log.txt", &
access="sequential", action="write", form="formatted", &
position="rewind" )
do index=1, rand_size
call random_number(rand)
if (rand(1) < 0.5_dp) then
rand_object(index) = ceiling(-rand(2)*hugep1, int32) - 1
else
rand_object(index) = floor(rand(2)*hugep1, int32)
end if
end do
test_object(:) = transfer( rand_object, 0_int8, test_size )
write(lun, '("| Algorithm | Key Size | Key # | Time (s) |")')
write(lun, '("| | Bytes | | |")')
write(lun, '("|------------|-----------|------------|----------|")')
call test_fnv_1()
call test_fnv_1a()
call test_nmhash32()
call test_nmhash32x()
call test_water()
contains
subroutine test_fnv_1()
integer :: index2
integer(int_hash) :: hash
real :: t1, t2, tdiff
integer(int_hash) :: summary(repeat)
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = fnv_1_hash( test_object( index2: &
index2+block_size(k)-1 ) )
if (index2 == index) summary(index) = hash
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'FNV-1', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_fnv_1
subroutine test_fnv_1a()
integer :: index2
integer(int_hash) :: hash
real :: t1, t2, tdiff
integer(int_hash) :: summary(repeat)
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = fnv_1a_hash( test_object( index2: &
index2+block_size(k)-1 ) )
if (index2 == index) summary(index) = hash
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'FNV-1a', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_fnv_1a
subroutine test_nmhash32()
integer :: index2
integer(int_hash) :: hash
integer(int32) :: seed = 0_int32
real :: t1, t2, tdiff
integer(int_hash) :: summary(repeat)
call new_nmhash32_seed( seed )
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = nmhash32( test_object( index2: &
index2+block_size(k)-1 ),&
seed )
if (index2 == index) summary(index) = hash
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'nmhash32', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_nmhash32
subroutine test_nmhash32x()
integer :: index2
integer(int_hash) :: hash
integer(int32) :: seed = 0_int32
real :: t1, t2, tdiff
integer(int_hash) :: summary(repeat)
call new_nmhash32x_seed( seed )
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = nmhash32x( test_object( index2: &
index2+block_size(k)-1 ),&
seed )
if (index2 == index) summary(index) = hash
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'nmhash32x', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_nmhash32x
subroutine test_water()
integer :: index2
integer(int_hash) :: hash
integer(int64) :: seed = 0_int64
real :: t1, t2, tdiff
integer(int_hash) :: summary(repeat)
call new_water_hash_seed( seed )
do k=1, size(block_size)
call cpu_time(t1)
do index=1, repeat
do index2=1, test_size, block_size(k)
hash = water_hash( test_object( index2: &
index2+block_size(k)-1 ),&
seed )
if (index2 == index) summary(index) = hash
end do
end do
call cpu_time(t2)
tdiff = t2-t1
write(lun, '("|", a10, 2x, "|", i8, 3x, "|", 1x, i10, 1x, ' // &
'"|", f9.5, 1x, "|")') 'water', &
block_size(k), repeat*(test_size/block_size(k)), tdiff
end do
end subroutine test_water
end program test_32_bit_hash_performance
fortran-lang-stdlib-0ede301/test/stats/ 0000775 0001750 0001750 00000000000 15135654166 020303 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/stats/test_rawmoment.f90 0000664 0001750 0001750 00000104112 15135654166 023672 0 ustar alastair alastair module test_rawmoment
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_kinds, only: sp, dp, int32
use stdlib_stats, only: mean, moment
use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
implicit none
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
real(dp), parameter :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp]
real(dp), parameter :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,&
2._dp, 4._dp, 6._dp, 8._dp,&
9._dp, 10._dp, 11._dp, 12._dp], [4, 3])
complex(sp), parameter :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp),&
cmplx(0.00000_sp, 1.44065_sp),&
cmplx(1.26401_sp, 0.00000_sp),&
cmplx(0.00000_sp, 0.88833_sp),&
cmplx(1.14352_sp, 0.00000_sp)]
complex(sp), parameter :: cs(5,3) = reshape([cs1, cs1*3.0_sp, cs1*1.5_sp], shape(cs))
contains
!> Collect all exported unit tests
subroutine collect_rawmoment(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("sp", test_sp), &
new_unittest("int32", test_int32), &
new_unittest("csp", test_csp) &
]
end subroutine collect_rawmoment
subroutine test_sp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(sp), parameter :: x1(5) = d1
real(sp), parameter :: x2(4, 3) = d
integer :: order
real(sp), allocatable :: x3(:, :, :)
real(sp), allocatable :: zero2_1(:), zero2_2(:)
real(sp), allocatable :: zero3_1(:,:), zero3_2(:,:), zero3_3(:,:)
allocate(zero2_1(size(x2, 2)), zero2_2(size(x2, 1)))
zero2_1 = 0
zero2_2 = 0
order = 1
!1dim
print*,' test_sp_1dim', order
call check(error, abs(moment(x1, order, center = 0.) - mean(x1)) < sptol)
call check(error, abs(moment(x1, order, 1, center = 0.) - mean(x1)) < sptol)
print*,' test_sp_1dim_mask', order
call check(error, ieee_is_nan(moment(x1, order, center = 0., mask = .false.)))
call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0., mask = .false.)))
print*,' test_sp_1dim_mask_array', order
call check(error, abs(moment(x1, order, center = 0., mask = (x1 < 5)) -&
mean(x1, mask = (x1 < 5)) ) < sptol)
call check(error, abs(moment(x1, order, dim = 1, center = 0., mask = (x1 < 5)) -&
mean(x1, dim = 1, mask = (x1 < 5))) < sptol)
!2dim
print*,' test_sp_2dim', order
call check(error, abs(moment(x2, order, center = 0.) - mean(x2)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = 0.) -&
mean(x2, dim = 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = 0.) -&
mean(x2, dim = 2)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
mean(x2, dim = 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
mean(x2, dim = 2)) < sptol))
print*,' test_sp_2dim_mask', order
call check(error, ieee_is_nan(moment(x2, order, center = 0., mask = .false.)))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,&
mask = .false.))))
print*,' test_sp_2dim_mask_array', order
call check(error, abs(moment(x2, order, center = 0., mask = (x2 < 11)) -&
mean(x2, x2 < 11)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = 0.,&
mask = (x2 < 11)) -&
mean(x2, 1, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = 0.,&
mask = (x2 < 11)) -&
mean(x2, 2, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
mask = (x2 < 11)) -&
mean(x2, 1, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,&
mask = (x2 < 11)) -&
mean(x2, 2, x2 < 11)) < sptol))
!3dim
allocate(x3(size(x2,1),size(x2,2),3))
x3(:,:,1)=x2;
x3(:,:,2)=x2*2;
x3(:,:,3)=x2*4;
allocate(zero3_1(size(x3, 2), size(x3, 3))&
,zero3_2(size(x3, 1), size(x3, 3))&
,zero3_3(size(x3, 1), size(x3, 2)))
zero3_1 = 0
zero3_2 = 0
zero3_3 = 0
print*,' test_sp_3dim', order
call check(error, abs(moment(x3, order, center = 0.) - mean(x3)) < sptol)
call check(error, all( abs( moment(x3, order, dim = 1, center = 0._sp) -&
mean(x3, 1)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 2, center = 0._sp) -&
mean(x3, 2)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 3, center = 0._sp) -&
mean(x3, 3)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -&
mean(x3, 1)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -&
mean(x3, 2)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -&
mean(x3, 3)) < sptol))
print*,' test_sp_3dim_mask', order
call check(error, ieee_is_nan(moment(x3, order, center = 0., mask = .false.)))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,&
mask = .false.))))
print*,' test_sp_3dim_mask_array', order
call check(error, abs(moment(x3, order, center = 0., mask = (x3 < 11)) -&
mean(x3, x3 < 11)) < sptol)
call check(error, all( abs( moment(x3, order, dim = 1, center = 0.,&
mask = (x3 < 45)) -&
mean(x3, 1, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 2, center = 0.,&
mask = (x3 < 45)) -&
mean(x3, 2, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 3, center = 0.,&
mask = (x3 < 45)) -&
mean(x3, 3, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,&
mask = (x3 < 45)) -&
mean(x3, 1, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,&
mask = (x3 < 45)) -&
mean(x3, 2, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,&
mask = (x3 < 45)) -&
mean(x3, 3, x3 < 45)) < sptol ))
order = 2
!1dim
print*,' test_sp_1dim', order
call check(error, abs(moment(x1, order, center = 0.) - mean(x1**2)) < sptol)
call check(error, abs(moment(x1, order, 1, center = 0.) - mean(x1**2, 1)) < sptol)
print*,' test_sp_1dim_mask', order
call check(error, ieee_is_nan(moment(x1, order, center = 0., mask = .false.)))
call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0., mask = .false.)))
print*,' test_sp_1dim_mask_array', order
call check(error, abs(moment(x1, order, center = 0., mask = (x1 < 5)) -&
mean(x1**2, x1 < 5)) < sptol)
call check(error, abs(moment(x1, order, dim = 1, center = 0., mask = (x1 < 5)) -&
mean(x1**2, 1, x1 < 5)) < sptol)
!2dim
print*,' test_sp_2dim', order
call check(error, abs(moment(x2, order, center = 0.) - mean(x2**2)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = 0.) -&
mean(x2**2, 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = 0.) - &
mean(x2**2, 2)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
mean(x2**2, 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) - &
mean(x2**2, 2)) < sptol))
print*,' test_sp_2dim_mask', order
call check(error, ieee_is_nan(moment(x2, order, center = 0., mask = .false.)))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1, &
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2, &
mask = .false.))))
print*,' test_sp_2dim_mask_array', order
call check(error, abs(moment(x2, order, center = 0., mask = (x2 < 11)) -&
mean(x2**2, x2 < 11)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = 0.,&
mask = (x2 < 11)) -&
mean(x2**2, 1, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = 0.,&
mask = (x2 < 11)) -&
mean(x2**2, 2, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
mask = (x2 < 11)) -&
mean(x2**2, 1, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,&
mask = (x2 < 11)) -&
mean(x2**2, 2, x2 < 11)) < sptol))
!3dim
print*,' test_sp_3dim', order
call check(error, abs(moment(x3, order, center = 0.) - mean(x3**2)) < sptol)
call check(error, all( abs( moment(x3, order, dim = 1, center = 0.) -&
mean(x3**2, 1)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 2, center = 0.) -&
mean(x3**2, 2)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 3, center = 0.) -&
mean(x3**2, 3)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -&
mean(x3**2, 1)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -&
mean(x3**2, 2)) < 1.5_sp*sptol))
call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -&
mean(x3**2, 3)) < sptol))
print*,' test_sp_3dim_mask', order
call check(error, ieee_is_nan(moment(x3, order, center = 0., mask = .false.)))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,&
mask = .false.))))
print*,' test_sp_3dim_mask_array', order
call check(error, abs(moment(x3, order, center = 0., mask = (x3 < 11)) -&
mean(x3**2, x3 < 11)) < sptol)
call check(error, all( abs( moment(x3, order, dim = 1, center = 0.,&
mask = (x3 < 45)) -&
mean(x3**2, 1, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 2, center = 0.,&
mask = (x3 < 45)) -&
mean(x3**2, 2, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 3, center = 0.,&
mask = (x3 < 45)) -&
mean(x3**2, 3, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,&
mask = (x3 < 45)) -&
mean(x3**2, 1, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,&
mask = (x3 < 45)) -&
mean(x3**2, 2, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,&
mask = (x3 < 45)) -&
mean(x3**2, 3, x3 < 45)) < sptol ))
end subroutine
subroutine test_int32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int32), parameter :: x1(5) = d1
integer(int32), parameter :: x2(4, 3) = d
integer :: order
integer(int32), allocatable :: x3(:, :, :)
real(dp), allocatable :: zero2_1(:), zero2_2(:)
real(dp), allocatable :: zero3_1(:,:), zero3_2(:,:), zero3_3(:,:)
allocate(zero2_1(size(x2, 2)), zero2_2(size(x2, 1)))
zero2_1 = 0
zero2_2 = 0
order = 1
!1dim
print*,' test_sp_1dim', order
call check(error, abs(moment(x1, order, center = 0._dp) - mean(x1)) < sptol)
call check(error, abs(moment(x1, order, 1, center = 0._dp) - mean(x1)) < sptol)
print*,' test_sp_1dim_mask', order
call check(error, ieee_is_nan(moment(x1, order, center = 0._dp, mask = .false.)))
call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0._dp,&
mask = .false.)))
print*,' test_sp_1dim_mask_array', order
call check(error, abs(moment(x1, order, center = 0._dp, mask = (x1 < 5)) -&
mean(x1, mask = (x1 < 5)) ) < sptol)
call check(error, abs(moment(x1, order, dim = 1, center = 0._dp, mask = (x1 < 5)) -&
mean(x1, dim = 1, mask = (x1 < 5))) < sptol)
!2dim
print*,' test_sp_2dim', order
call check(error, abs(moment(x2, order, center = 0._dp) - mean(x2)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp) -&
mean(x2, dim = 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp) -&
mean(x2, dim = 2)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
mean(x2, dim = 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
mean(x2, dim = 2)) < sptol))
print*,' test_sp_2dim_mask', order
call check(error, ieee_is_nan(moment(x2, order, center = 0._dp, mask = .false.)))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,&
mask = .false.))))
print*,' test_sp_2dim_mask_array', order
call check(error, abs(moment(x2, order, center = 0._dp, mask = (x2 < 11)) -&
mean(x2, x2 < 11)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp,&
mask = (x2 < 11)) -&
mean(x2, 1, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp,&
mask = (x2 < 11)) -&
mean(x2, 2, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
mask = (x2 < 11)) -&
mean(x2, 1, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,&
mask = (x2 < 11)) -&
mean(x2, 2, x2 < 11)) < sptol))
!3dim
allocate(x3(size(x2,1),size(x2,2),3))
x3(:,:,1)=x2;
x3(:,:,2)=x2*2;
x3(:,:,3)=x2*4;
allocate(zero3_1(size(x3, 2), size(x3, 3))&
,zero3_2(size(x3, 1), size(x3, 3))&
,zero3_3(size(x3, 1), size(x3, 2)))
zero3_1 = 0
zero3_2 = 0
zero3_3 = 0
print*,' test_sp_3dim', order
call check(error, abs(moment(x3, order, center = 0._dp) - mean(x3)) < sptol)
call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp) -&
mean(x3, 1)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp) -&
mean(x3, 2)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp) -&
mean(x3, 3)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -&
mean(x3, 1)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -&
mean(x3, 2)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -&
mean(x3, 3)) < sptol))
print*,' test_sp_3dim_mask', order
call check(error, ieee_is_nan(moment(x3, order, center = 0._dp, mask = .false.)))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,&
mask = .false.))))
print*,' test_sp_3dim_mask_array', order
call check(error, abs(moment(x3, order, center = 0._dp, mask = (x3 < 11)) -&
mean(x3, x3 < 11)) < sptol)
call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp,&
mask = (x3 < 45)) -&
mean(x3, 1, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp,&
mask = (x3 < 45)) -&
mean(x3, 2, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp,&
mask = (x3 < 45)) -&
mean(x3, 3, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,&
mask = (x3 < 45)) -&
mean(x3, 1, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,&
mask = (x3 < 45)) -&
mean(x3, 2, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,&
mask = (x3 < 45)) -&
mean(x3, 3, x3 < 45)) < sptol ))
order = 2
!1dim
print*,' test_sp_1dim', order
call check(error, abs(moment(x1, order, center = 0._dp) - mean(x1**2)) < sptol)
call check(error, abs(moment(x1, order, 1, center = 0._dp) - mean(x1**2, 1)) < sptol)
print*,' test_sp_1dim_mask', order
call check(error, ieee_is_nan(moment(x1, order, center = 0._dp, mask = .false.)))
call check(error, ieee_is_nan(moment(x1, order, dim = 1, center = 0._dp,&
mask = .false.)))
print*,' test_sp_1dim_mask_array', order
call check(error, abs(moment(x1, order, center = 0._dp, mask = (x1 < 5)) -&
mean(x1**2, x1 < 5)) < sptol)
call check(error, abs(moment(x1, order, dim = 1, center = 0._dp, mask = (x1 < 5)) -&
mean(x1**2, 1, x1 < 5)) < sptol)
!2dim
print*,' test_sp_2dim', order
call check(error, abs(moment(x2, order, center = 0._dp) - mean(x2**2)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp) -&
mean(x2**2, 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp) -&
mean(x2**2, 2)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
mean(x2**2, 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
mean(x2**2, 2)) < sptol))
print*,' test_sp_2dim_mask', order
call check(error, ieee_is_nan(moment(x2, order, center = 0._dp, mask = .false.)))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = 0._dp,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = 0._dp,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 1, center = zero2_1,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x2, order, dim = 2, center = zero2_2,&
mask = .false.))))
print*,' test_sp_2dim_mask_array', order
call check(error, abs(moment(x2, order, center = 0._dp, mask = (x2 < 11)) -&
mean(x2**2, x2 < 11)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = 0._dp,&
mask = (x2 < 11)) -&
mean(x2**2, 1, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = 0._dp,&
mask = (x2 < 11)) -&
mean(x2**2, 2, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
mask = (x2 < 11)) -&
mean(x2**2, 1, x2 < 11)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2,&
mask = (x2 < 11)) -&
mean(x2**2, 2, x2 < 11)) < sptol))
!3dim
print*,' test_sp_3dim', order
call check(error, abs(moment(x3, order, center = 0._dp) - mean(x3**2)) < sptol)
call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp) -&
mean(x3**2, 1)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp) -&
mean(x3**2, 2)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp) -&
mean(x3**2, 3)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1) -&
mean(x3**2, 1)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2) -&
mean(x3**2, 2)) < sptol))
call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3) -&
mean(x3**2, 3)) < sptol))
print*,' test_sp_3dim_mask', order
call check(error, ieee_is_nan(moment(x3, order, center = 0._dp, mask = .false.)))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = 0._dp,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = 0._dp,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = 0._dp,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 1, center = zero3_1,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 2, center = zero3_2,&
mask = .false.))))
call check(error, any(ieee_is_nan(moment(x3, order, dim = 3, center = zero3_3,&
mask = .false.))))
print*,' test_sp_3dim_mask_array', order
call check(error, abs(moment(x3, order, center = 0._dp, mask = (x3 < 11)) -&
mean(x3**2, x3 < 11)) < sptol)
call check(error, all( abs( moment(x3, order, dim = 1, center = 0._dp,&
mask = (x3 < 45)) -&
mean(x3**2, 1, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 2, center = 0._dp,&
mask = (x3 < 45)) -&
mean(x3**2, 2, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 3, center = 0._dp,&
mask = (x3 < 45)) -&
mean(x3**2, 3, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 1, center = zero3_1,&
mask = (x3 < 45)) -&
mean(x3**2, 1, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 2, center = zero3_2,&
mask = (x3 < 45)) -&
mean(x3**2, 2, x3 < 45)) < sptol ))
call check(error, all( abs( moment(x3, order, dim = 3, center = zero3_3,&
mask = (x3 < 45)) -&
mean(x3**2, 3, x3 < 45)) < sptol ))
end subroutine
subroutine test_csp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(sp), parameter :: x1(5) = cs1
complex(sp), parameter :: x2(5, 3) = cs
integer :: order
complex(sp), allocatable :: zero2_1(:), zero2_2(:)
allocate(zero2_1(size(x2, 2)), zero2_2(size(x2, 1)))
zero2_1 = (0., 0.)
zero2_2 = (0., 0.)
order = 1
!1dim
print*,' test_sp_1dim', order
call check(error, abs(moment(x1, order, center = (0., 0.)) - mean(x1)) < sptol)
call check(error, abs(moment(x1, order, 1, center = (0., 0.)) - mean(x1, 1)) < sptol)
print*,' test_sp_1dim_mask', order
call check(error, ieee_is_nan(abs(moment(x1, order, center = (0., 0.),&
mask = .false.))))
call check(error, ieee_is_nan(abs(moment(x1, order, dim = 1, center = (0., 0.),&
mask = .false.))))
print*,' test_sp_1dim_mask_array', order
call check(error, abs(moment(x1, order, center = (0., 0.), mask = (aimag(x1) == 0)) -&
mean(x1, aimag(x1) == 0)) < sptol)
call check(error, abs(moment(x1, order, dim = 1, center = (0., 0.),&
mask = (aimag(x1) == 0)) -&
mean(x1, 1, aimag(x1) == 0)) < sptol)
!2dim
print*,' test_sp_2dim', order
call check(error, abs(moment(x2, order, center = (0., 0.)) - mean(x2)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.)) -&
mean(x2, 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = (0., 0.)) -&
mean(x2, 2)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
mean(x2, 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
mean(x2, 2)) < sptol))
print*,' test_sp_2dim_mask', order
call check(error, ieee_is_nan(abs(moment(x2, order, center = (0., 0.),&
mask = .false.))))
call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = (0., 0.),&
mask = .false.)))))
call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = (0., 0.),&
mask = .false.)))))
call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = zero2_1,&
mask = .false.)))))
call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = zero2_2,&
mask = .false.)))))
print*,' test_sp_2dim_mask_array', order
call check(error, abs(moment(x2, order, center = (0., 0.), mask = (aimag(x2) == 0)) -&
mean(x2, aimag(x2) == 0)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.),&
mask = (aimag(x2) == 0)) -&
mean(x2, 1, aimag(x2) == 0)) < sptol))
call check(error, any(ieee_is_nan( abs( moment(x2, order,&
dim = 2, center = (0., 0.), mask = (aimag(x2) == 0)) -&
mean(x2, 2, aimag(x2) == 0)))))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
mask = (aimag(x2) == 0)) -&
mean(x2, 1, aimag(x2) == 0)) < sptol))
call check(error, any(ieee_is_nan( abs( moment(x2, order,&
dim = 2, center = zero2_2, mask = (aimag(x2) == 0)) -&
mean(x2, 2, aimag(x2) == 0)))))
order = 2
!1dim
print*,' test_sp_1dim', order
call check(error, abs(moment(x1, order, center = (0., 0.)) - mean(x1**2)) < sptol)
call check(error, abs(moment(x1, order, 1, center = (0., 0.)) -&
mean(x1**2, 1)) < sptol)
print*,' test_sp_1dim_mask', order
call check(error, ieee_is_nan(abs(moment(x1, order, center = (0., 0.),&
mask = .false.))))
call check(error, ieee_is_nan(abs(moment(x1, order, dim = 1, center = (0., 0.),&
mask = .false.))))
print*,' test_sp_1dim_mask_array', order
call check(error, abs(moment(x1, order, center = (0., 0.), mask = (aimag(x1) == 0)) -&
mean(x1**2, aimag(x1) == 0)) < sptol)
call check(error, abs(moment(x1, order, dim = 1, center = (0., 0.),&
mask = (aimag(x1) == 0)) -&
mean(x1**2, 1, aimag(x1) == 0)) < sptol)
!2dim
print*,' test_sp_2dim', order
call check(error, abs(moment(x2, order, center = (0., 0.)) - mean(x2**2)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = (0., 0.)) -&
mean(x2**2, 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = (0., 0.)) -&
mean(x2**2, 2)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1) -&
mean(x2**2, 1)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 2, center = zero2_2) -&
mean(x2**2, 2)) < sptol))
print*,' test_sp_2dim_mask', order
call check(error, ieee_is_nan(abs(moment(x2, order, center = (0., 0.),&
mask = .false.))))
call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = (0., 0.),&
mask = .false.)))))
call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = (0., 0.),&
mask = .false.)))))
call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 1, center = zero2_1,&
mask = .false.)))))
call check(error, any(ieee_is_nan(abs(moment(x2, order, dim = 2, center = zero2_2,&
mask = .false.)))))
print*,' test_sp_2dim_mask_array', order
call check(error, abs(moment(x2, order, center = (0., 0.), mask = (aimag(x2) == 0)) -&
mean(x2**2, aimag(x2) == 0)) < sptol)
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
mask = (aimag(x2)==0)) -&
mean(x2**2, 1, aimag(x2)==0)) < sptol))
call check(error, all( abs( moment(x2, order, dim = 1, center = zero2_1,&
mask = (aimag(x2)==0)) -&
mean(x2**2, 1, aimag(x2)==0)) < sptol))
end subroutine
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_rawmoment, only : collect_rawmoment
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("rawmoment", collect_rawmoment) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/stats/test_median.fypp 0000664 0001750 0001750 00000050061 15135654166 023501 0 ustar alastair alastair #:include "common.fypp"
#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES
#:set NRANK = 3
module test_stats_median
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_stats, only: median
use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, xdp, qp
use, intrinsic :: ieee_arithmetic, only : ieee_is_nan
implicit none
private
public :: collect_stats_median
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 2000 * epsilon(1._dp)
#:if WITH_XDP
real(xdp), parameter :: xdptol = 2000 * epsilon(1._xdp)
#:endif
#:if WITH_QP
real(qp), parameter :: qptol = 2000 * epsilon(1._qp)
#:endif
#:for k1,t1 in IR_KINDS_TYPES
${t1}$ , parameter :: d1_${k1}$(12) = [${t1}$ :: 10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
${t1}$ :: d2_${k1}$(3, 4) = reshape(d1_${k1}$, [3, 4])
${t1}$ :: d3_${k1}$(2, 3, 2) = reshape(d1_${k1}$, [2, 3, 2])
${t1}$ , parameter :: d1odd_${k1}$(13) = [${t1}$ :: d1_${k1}$, 20]
${t1}$ :: d2odd_${k1}$(3, 5) = reshape(d1odd_${k1}$, [3, 5], [${t1}$ :: 0])
${t1}$ :: d3odd_${k1}$(1, 3, 5) = reshape(d1odd_${k1}$, [1, 3, 5], [${t1}$ :: 0])
#:endfor
contains
!> Collect all exported unit tests
subroutine collect_stats_median(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("test_stats_median_size_int8", test_stats_median_size_int8) &
#:for k1,t1 in IR_KINDS_TYPES
, new_unittest("test_stats_median_size_${k1}$", test_stats_median_size_${k1}$) &
, new_unittest("test_stats_median_odd_size_${k1}$", test_stats_median_odd_size_${k1}$) &
, new_unittest("test_stats_median_all_${k1}$", test_stats_median_all_${k1}$) &
, new_unittest("test_stats_median_all_odd_${k1}$", test_stats_median_all_odd_${k1}$) &
, new_unittest("test_stats_median_all_optmask_${k1}$", test_stats_median_all_optmask_${k1}$) &
, new_unittest("test_stats_median_${k1}$", test_stats_median_${k1}$) &
, new_unittest("test_stats_median_odd_${k1}$", test_stats_median_odd_${k1}$) &
, new_unittest("test_stats_median_optmask_${k1}$", test_stats_median_optmask_${k1}$) &
, new_unittest("test_stats_median_mask_all_${k1}$", test_stats_median_mask_all_${k1}$) &
, new_unittest("test_stats_median_mask_${k1}$", test_stats_median_mask_${k1}$) &
#:endfor
]
end subroutine collect_stats_median
#:for k1,t1 in INT_KINDS_TYPES
subroutine test_stats_median_size_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
!check just to be sure that the setup of d0 is correct
call check(error, size(d0), 0, 'size(d0): should be of size 0')
#:for rank in range(1, NRANK + 1)
call check(error, mod(size(d${rank}$_${k1}$), 2), 0&
, 'mod(size(d${rank}$_${k1}$), 2): should be an even number'&
)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_odd_size_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK + 1)
call check(error, mod(size(d${rank}$odd_${k1}$), 2), 1&
, 'mod(size(d${rank}$)_${k1}$, 2): should be an odd number'&
)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error, ieee_is_nan(median(d0)), 'median(d0): should be NaN' )
if (allocated(error)) return
#:for rank in range(1, NRANK + 1)
call check(error, median(d${rank}$_${k1}$), 1.5_dp&
, 'median(d${rank}$_${k1}$): uncorrect answer'&
, thr = dptol)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_all_odd_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, median(d1odd_${k1}$), 2._dp&
, 'median(d1odd_${k1}$): uncorrect answer'&
, thr = dptol)
if (allocated(error)) return
call check(error, median(d2odd_${k1}$), 1._dp&
, 'median(d2odd_${k1}$): uncorrect answer'&
, thr = dptol)
end subroutine
subroutine test_stats_median_all_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0_${k1}$(:)
allocate(d0_${k1}$(0))
#:for rank in range(0, NRANK + 1)
call check(error, ieee_is_nan(median(d${rank}$_${k1}$, .false.))&
, 'median(d${rank}$_${k1}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error, ieee_is_nan(median(d0, 1)), 'median(d0, 1): should return NaN' )
call check(error&
, abs(median(d1_${k1}$, 1) - 1.5_dp) < dptol&
, 'median(d1_${k1}$, 1): uncorrect answer'&
)
if (allocated(error)) return
call check(error&
, sum(abs(median(d2_${k1}$, 1) - [2._dp, -4._dp, 7._dp, 1._dp])) < dptol&
, 'median(d2_${k1}$, 1): uncorrect answer')
if (allocated(error)) return
call check(error&
, sum(abs(median(d2_${k1}$, 2) - [3.5_dp, 1.5_dp, 3._dp])) < dptol&
,'median(d2_${k1}$, 2): uncorrect answer')
if (allocated(error)) return
end subroutine
subroutine test_stats_median_odd_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error&
, abs(median(d1odd_${k1}$, 1) - 2._dp) < dptol&
, 'median(d1odd_${k1}$, 1): wrong answer')
if (allocated(error)) return
call check(error&
, sum(abs(median(d2odd_${k1}$, 1) - [2._dp, -4._dp, 7._dp, 1._dp, 0._dp])) < dptol&
, 'median(d2odd_${k1}$, 1): wrong answer')
if (allocated(error)) return
call check(error&
, sum(abs(median(d2odd_${k1}$, 2) - [7._dp, 1._dp, 0._dp])) < dptol&
, 'median(d2odd_${k1}$, 2): wrong answer')
if (allocated(error)) return
end subroutine
subroutine test_stats_median_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error, ieee_is_nan(median(d0, 1, .false.))&
, 'median(d0, 1, .false.): uncorrect answer'&
)
if (allocated(error)) return
call check(error, ieee_is_nan(median(d1_${k1}$, 1, .false.))&
, 'median(d1_${k1}$, 1, .false.): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error, any(ieee_is_nan(median(d${rank}$_${k1}$, ${dim}$, .false.)))&
, 'median(d${rank}$_${k1}$, ${dim}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
subroutine test_stats_median_mask_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error, ieee_is_nan(median(d0, d0 > 0))&
, 'median(d0, d0 > 0): should be NaN' )
if (allocated(error)) return
#:for rank in range(1, NRANK+1)
call check(error&
, ieee_is_nan(median(d${rank}$_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$)))&
, 'median(d${rank}$_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$))' )
if (allocated(error)) return
#:endfor
#:for rank in range(1, NRANK+1)
call check(error&
, (median(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0) - 7._dp) < dptol&
, 'median(d${rank}$_${k1}$, d${rank}$_${k1}$> 0)' )
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_mask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error&
, ieee_is_nan(median(d0, 1, d0 > 0))&
, 'median(d0, 1, d0 > 0): uncorrect answer' )
if (allocated(error)) return
call check(error&
, ieee_is_nan(median(d1_${k1}$, 1, d1_${k1}$ > huge(d1_${k1}$)))&
, 'median(d1_${k1}$, 1_${k1}$, d1_${k1}$ > huge(d1_${k1}$)): answer should be IEEE NaN' )
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
call check(error&
, any(ieee_is_nan(median(d${rank}$_${k1}$, 1, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$))))&
, 'median(d${rank}$_${k1}$, 1_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$)): answer should be IEEE NaN' )
if (allocated(error)) return
#:endfor
call check(error&
, (median(d1_${k1}$, 1, d1_${k1}$ > 0) - 7._dp) < dptol&
, 'median(d1_${k1}$, 1, d1_${k1}$ >0): uncorrect answer')
if (allocated(error)) return
call check(error&
, sum(abs( (median(d2_${k1}$, 1, d2_${k1}$ > 0) - [ 6._dp, 6._dp, 8._dp, 10.5_dp] ) )) &
< dptol&
, 'median(d2_${k1}$, 1, d2_${k1}$ > 0): uncorrect answer')
if (allocated(error)) return
call check(error&
, sum(abs((median(d2_${k1}$, 2, d2_${k1}$ > 0) - [ 8.5_dp, 2._dp, 14.5_dp] )))&
< dptol&
, 'median(d2_${k1}$, 2, d2_${k1}$ > 0)')
if (allocated(error)) return
call check(error&
, any(ieee_is_nan(median(d3_${k1}$, 1, d3_${k1}$ > 0)))&
, 'median(d3_${k1}$, 1, d3_${k1}$ > 0): should contain at least 1 IEEE NaN')
end subroutine
#:endfor
#:for k1,t1 in REAL_KINDS_TYPES
subroutine test_stats_median_size_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
!check just to be sure that the setup of d0 is correct
call check(error, size(d0), 0, 'size(d0): should be of size 0')
#:for rank in range(1, NRANK + 1)
call check(error, mod(size(d${rank}$_${k1}$), 2), 0&
, 'mod(size(d${rank}$_${k1}$), 2): should be an even number'&
)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_odd_size_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK + 1)
call check(error, mod(size(d${rank}$odd_${k1}$), 2), 1&
, 'mod(size(d${rank}$_${k1}$), 2): should be an odd number'&
)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error, ieee_is_nan(median(d0)), 'median(d0): should be NaN' )
if (allocated(error)) return
#:for rank in range(1, NRANK + 1)
call check(error, median(d${rank}$_${k1}$), 1.5_${k1}$&
, 'median(d${rank}$_${k1}$): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_all_odd_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, median(d1odd_${k1}$), 2._${k1}$&
, 'median(d1odd_${k1}$): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
call check(error, median(d2odd_${k1}$), 1._${k1}$&
, 'median(d2odd_${k1}$): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
call check(error, median(d2odd_${k1}$), 1._${k1}$&
, 'median(d2odd_${k1}$): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
end subroutine
subroutine test_stats_median_all_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0_${k1}$(:)
allocate(d0_${k1}$(0))
#:for rank in range(0, NRANK + 1)
call check(error, ieee_is_nan(median(d${rank}$_${k1}$, .false.))&
, 'median(d${rank}$_${k1}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error, ieee_is_nan(median(d0, 1)), 'median(d0, 1): should return NaN' )
call check(error&
, abs(median(d1_${k1}$, 1) - 1.5_${k1}$) < ${k1}$tol&
, 'median(d1_${k1}$, 1): uncorrect answer'&
)
if (allocated(error)) return
call check(error&
, sum(abs(median(d2_${k1}$, 1) - [2._${k1}$, -4._${k1}$, 7._${k1}$, 1._${k1}$])) < ${k1}$tol&
, 'median(d2_${k1}$, 1): uncorrect answer')
if (allocated(error)) return
call check(error&
, sum(abs(median(d2_${k1}$, 2) - [3.5_${k1}$, 1.5_${k1}$, 3._${k1}$])) < ${k1}$tol&
,'median(d2_${k1}$, 2): uncorrect answer')
if (allocated(error)) return
end subroutine
subroutine test_stats_median_odd_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error&
, abs(median(d1odd_${k1}$, 1) - 2._${k1}$) < ${k1}$tol&
, 'median(d1odd_${k1}$, 1): wrong answer')
if (allocated(error)) return
call check(error&
, sum(abs(median(d2odd_${k1}$, 1) - [2._${k1}$, -4._${k1}$, 7._${k1}$, 1._${k1}$, 0._${k1}$])) < ${k1}$tol&
, 'median(d2odd_${k1}$, 1): wrong answer')
if (allocated(error)) return
call check(error&
, sum(abs(median(d2odd_${k1}$, 2) - [7._${k1}$, 1._${k1}$, 0._${k1}$])) < ${k1}$tol&
, 'median(d2odd_${k1}$, 2): wrong answer')
if (allocated(error)) return
end subroutine
subroutine test_stats_median_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error, ieee_is_nan(median(d0, 1, .false.))&
, 'median(d0, 1, .false.): uncorrect answer'&
)
if (allocated(error)) return
call check(error, ieee_is_nan(median(d1_${k1}$, 1, .false.))&
, 'median(d1_${k1}$, 1, .false.): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error, any(ieee_is_nan(median(d${rank}$_${k1}$, ${dim}$, .false.)))&
, 'median(d${rank}$_${k1}$, ${dim}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
subroutine test_stats_median_mask_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error, ieee_is_nan(median(d0, d0 > 0))&
, 'median(d0, d0 > 0): should be NaN' )
if (allocated(error)) return
#:for rank in range(1, NRANK+1)
call check(error&
, ieee_is_nan(median(d${rank}$_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$)))&
, 'median(d${rank}$_${k1}$, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$))' )
if (allocated(error)) return
#:endfor
#:for rank in range(1, NRANK+1)
call check(error&
, (median(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0) - 7._${k1}$) < ${k1}$tol&
, 'median(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)' )
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_median_mask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, allocatable :: d0(:)
allocate(d0(0))
call check(error&
, ieee_is_nan(median(d0, 1, d0 > 0))&
, 'median(d0, 1, d0 > 0): uncorrect answer' )
if (allocated(error)) return
call check(error&
, ieee_is_nan(median(d1_${k1}$, 1, d1_${k1}$ > huge(d1_${k1}$)))&
, 'median(d1_${k1}$, 1, d1_${k1}$ > huge(d1_${k1}$)): answer should be IEEE NaN' )
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
call check(error&
, any(ieee_is_nan(median(d${rank}$_${k1}$, 1, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$))))&
, 'median(d${rank}$_${k1}$, 1, d${rank}$_${k1}$ > huge(d${rank}$_${k1}$)): answer should be IEEE NaN' )
if (allocated(error)) return
#:endfor
call check(error&
, (median(d1_${k1}$, 1, d1_${k1}$ > 0) - 7._${k1}$) < ${k1}$tol&
, 'median(d1_${k1}$, 1, d1_${k1}$ >0): uncorrect answer')
if (allocated(error)) return
call check(error&
, sum(abs( (median(d2_${k1}$, 1, d2_${k1}$ > 0) - [ 6._${k1}$, 6._${k1}$, 8._${k1}$, 10.5_${k1}$] ) )) &
< ${k1}$tol&
, 'median(d2_${k1}$, 1, d2_${k1}$ > 0): uncorrect answer')
if (allocated(error)) return
call check(error&
, sum(abs((median(d2_${k1}$, 2, d2_${k1}$ > 0) - [ 8.5_${k1}$, 2._${k1}$, 14.5_${k1}$] )))&
< ${k1}$tol&
, 'median(d2_${k1}$, 2, d2_${k1}$ > 0)')
if (allocated(error)) return
call check(error&
, any(ieee_is_nan(median(d3_${k1}$, 1, d3_${k1}$ > 0)))&
, 'median(d3_${k1}$, 1, d3_${k1}$ > 0): should contain at least 1 IEEE NaN')
end subroutine
#:endfor
end module test_stats_median
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_stats_median, only : collect_stats_median
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("stats_median", collect_stats_median) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/stats/test_cov.f90 0000664 0001750 0001750 00000057055 15135654166 022465 0 ustar alastair alastair program test_cov
use stdlib_error, only: check
use stdlib_kinds, only: sp, dp, int32, int64
use stdlib_stats, only: cov, var
use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
implicit none
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
real(dp) :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp]
real(dp) :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,&
2._dp, 4._dp, 6._dp, 8._dp,&
9._dp, 10._dp, 11._dp, 12._dp], [4, 3])
complex(dp) :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp,kind=dp),&
cmplx(0.00000_dp, 1.44065_dp,kind=dp),&
cmplx(1.26401_dp, 0.00000_dp,kind=dp),&
cmplx(0.00000_dp, 0.88833_dp,kind=dp),&
cmplx(1.14352_dp, 0.00000_dp,kind=dp)]
complex(dp) :: ds(2,3) = reshape([ cmplx(1._dp, 0._dp,kind=dp),&
cmplx(0._dp, 2._dp,kind=dp),&
cmplx(3._dp, 0._dp,kind=dp),&
cmplx(0._dp, 4._dp,kind=dp),&
cmplx(5._dp, 0._dp,kind=dp),&
cmplx(0._dp, 6._dp,kind=dp)], [2, 3])
call test_sp(real(d1, sp), real(d, sp))
call test_dp(d1,d)
call test_int32(int(d1, int32) ,int(d, int32))
call test_int64(int(d1, int64) ,int(d, int64))
call test_csp(cmplx(cd1, kind = sp), cmplx(ds, kind = sp))
call test_cdp(cd1, ds)
contains
subroutine test_sp(x, x2)
real(sp), intent(in) :: x(:)
real(sp), intent(in) :: x2(:, :)
call check( abs(cov(x, 1) - 2.5_sp) < sptol&
, 'sp check 1')
call check( ieee_is_nan(cov(x, 1, .false.))&
, 'sp check 2')
call check( ieee_is_nan((cov(x, 1, x == 1.)))&
, 'sp check 3')
call check( abs(cov(x, 1, x < 5) - 5._sp/3) < sptol&
, 'sp check 4')
call check( abs(cov(x, 1, x < 5, corrected = .false.) -&
5._sp/4) < sptol&
, 'sp check 5')
call check( any(ieee_is_nan(cov(x2, 1, mask = .false.)))&
, 'sp check 6')
call check( any(ieee_is_nan(cov(x2, 2, mask = .false.)))&
, 'sp check 7')
call check( all( abs( cov(x2, 1) - reshape([&
60._sp/9, 60._sp/9, 30._sp/9&
,60._sp/9, 60._sp/9, 30._sp/9&
,30._sp/9, 30._sp/9, 15._sp/9]&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'sp check 8')
call check( all( abs( cov(x2, 2) - reshape([&
19._sp, 16.5_sp, 14._sp, 11.5_sp, 16.5_sp, 129._sp/9&
,109.5_sp/9, 10._sp, 14._sp, 109.5_sp/9, 93._sp/9&
, 8.5_sp, 11.5_sp, 10._sp, 8.5_sp, 7._sp]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'sp check 9')
call check( all( abs( cov(x2, 1, corrected=.false.) - reshape([&
60._sp/9, 60._sp/9, 30._sp/9&
,60._sp/9, 60._sp/9, 30._sp/9&
,30._sp/9, 30._sp/9, 15._sp/9]&
*(size(x2, 1)-1._sp)/size(x2, 1)&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'sp check 10')
call check( all( abs( cov(x2, 2, corrected=.false.) - reshape([&
19._sp, 16.5_sp, 14._sp, 11.5_sp, 16.5_sp, 129._sp/9&
,109.5_sp/9, 10._sp, 14._sp, 109.5_sp/9, 93._sp/9&
, 8.5_sp, 11.5_sp, 10._sp, 8.5_sp, 7._sp]&
*(size(x2, 2)-1._sp)/size(x2, 2)&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'sp check 11')
call check( any(ieee_is_nan(cov(x2, 1, mask = x2 < 10)))&
, 'sp check 12')
call check( all( abs( cov(x2, 1, mask = x2 < 11) - reshape([&
60._sp/9, 60._sp/9, 1._sp, 60._sp/9, 60._sp/9, 1._sp&
, 1._sp, 1._sp, 0.5_sp]&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'sp check 13')
call check( all( abs( cov(x2, 2, mask = x2 < 11) - reshape([&
19._sp, 16.5_sp, 0.5_sp, 0.5_sp, 16.5_sp&
,129._sp/9, 0.5_sp, 0.5_sp, 0.5_sp, 0.5_sp&
,0.5_sp, 0.5_sp, 0.5_sp, 0.5_sp, 0.5_sp, 0.5_sp]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'sp check 14')
call check( all( abs( cov(x2, 1, mask = x2 < 11, corrected = .false.) -&
reshape([&
5._sp, 5._sp, 0.5_sp, 5._sp, 5._sp, 0.5_sp, 0.5_sp,&
0.5_sp, 0.25_sp]&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'sp check 15')
call check( all( abs( cov(x2, 2, mask = x2 < 11, corrected = .false.) -&
reshape([&
114._sp/9, 11._sp, 0.25_sp, 0.25_sp, 11._sp, 86._sp/9,&
0.25_sp, 0.25_sp, 0.25_sp, 0.25_sp, 0.25_sp, 0.25_sp,&
0.25_sp, 0.25_sp, 0.25_sp, 0.25_sp]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'sp check 16')
call check( all( abs( cov(x2, 1, mask = x2 < 1000) - cov(x2, 1))&
< sptol)&
, 'sp check 17')
call check( all( abs( cov(x2, 2, mask = x2 < 1000) - cov(x2, 2))&
< sptol)&
, 'sp check 18')
end subroutine test_sp
subroutine test_dp(x, x2)
real(dp), intent(in) :: x(:)
real(dp), intent(in) :: x2(:, :)
call check( abs(cov(x, 1) - 2.5_dp) < dptol&
, 'dp check 1')
call check( ieee_is_nan(cov(x, 1, .false.))&
, 'dp check 2')
call check( ieee_is_nan((cov(x, 1, x == 1.)))&
, 'dp check 3')
call check( abs(cov(x, 1, x < 5) - 5._dp/3) < dptol&
, 'dp check 4')
call check( abs(cov(x, 1, x < 5, corrected = .false.) -&
5._dp/4) < dptol&
, 'dp check 5')
call check( any(ieee_is_nan(cov(x2, 1, mask = .false.)))&
, 'dp check 6')
call check( any(ieee_is_nan(cov(x2, 2, mask = .false.)))&
, 'dp check 7')
call check( all( abs( cov(x2, 1) - reshape([&
60._dp/9, 60._dp/9, 30._dp/9&
,60._dp/9, 60._dp/9, 30._dp/9&
,30._dp/9, 30._dp/9, 15._dp/9]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'dp check 8')
call check( all( abs( cov(x2, 2) - reshape([&
19._dp, 16.5_dp, 14._dp, 11.5_dp, 16.5_dp, 129._dp/9&
,109.5_dp/9, 10._dp, 14._dp, 109.5_dp/9, 93._dp/9&
, 8.5_dp, 11.5_dp, 10._dp, 8.5_dp, 7._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'dp check 9')
call check( all( abs( cov(x2, 1, corrected=.false.) - reshape([&
60._dp/9, 60._dp/9, 30._dp/9&
,60._dp/9, 60._dp/9, 30._dp/9&
,30._dp/9, 30._dp/9, 15._dp/9]&
*(size(x2, 1)-1._dp)/size(x2, 1)&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'dp check 10')
call check( all( abs( cov(x2, 2, corrected=.false.) - reshape([&
19._dp, 16.5_dp, 14._dp, 11.5_dp, 16.5_dp, 129._dp/9&
,109.5_dp/9, 10._dp, 14._dp, 109.5_dp/9, 93._dp/9&
, 8.5_dp, 11.5_dp, 10._dp, 8.5_dp, 7._dp]&
*(size(x2, 2)-1._dp)/size(x2, 2)&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'dp check 11')
call check( any(ieee_is_nan(cov(x2, 1, mask = x2 < 10)))&
, 'dp check 12')
call check( all( abs( cov(x2, 1, mask = x2 < 11) - reshape([&
60._dp/9, 60._dp/9, 1._dp, 60._dp/9, 60._dp/9, 1._dp&
, 1._dp, 1._dp, 0.5_dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'dp check 13')
call check( all( abs( cov(x2, 2, mask = x2 < 11) - reshape([&
19._dp, 16.5_dp, 0.5_dp, 0.5_dp, 16.5_dp&
,129._dp/9, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp&
,0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'dp check 14')
call check( all( abs( cov(x2, 1, mask = x2 < 11, corrected = .false.) -&
reshape([&
5._dp, 5._dp, 0.5_dp, 5._dp, 5._dp, 0.5_dp, 0.5_dp,&
0.5_dp, 0.25_dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'dp check 15')
call check( all( abs( cov(x2, 2, mask = x2 < 11, corrected = .false.) -&
reshape([&
114._dp/9, 11._dp, 0.25_dp, 0.25_dp, 11._dp, 86._dp/9,&
0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp,&
0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'dp check 16')
call check( all( abs( cov(x2, 1, mask = x2 < 1000) - cov(x2, 1))&
< dptol)&
, 'dp check 17')
call check( all( abs( cov(x2, 2, mask = x2 < 1000) - cov(x2, 2))&
< dptol)&
, 'dp check 18')
end subroutine test_dp
subroutine test_int32(x, x2)
integer(int32), intent(in) :: x(:)
integer(int32), intent(in) :: x2(:, :)
call check( abs(cov(x, 1) - 2.5_dp) < dptol&
, 'int32 check 1')
call check( ieee_is_nan(cov(x, 1, .false.))&
, 'int32 check 2')
call check( ieee_is_nan((cov(x, 1, x == 1.)))&
, 'int32 check 3')
call check( abs(cov(x, 1, x < 5) - 5._dp/3) < dptol&
, 'int32 check 4')
call check( abs(cov(x, 1, x < 5, corrected = .false.) -&
5._dp/4) < dptol&
, 'int32 check 5')
call check( any(ieee_is_nan(cov(x2, 1, mask = .false.)))&
, 'int32 check 6')
call check( any(ieee_is_nan(cov(x2, 2, mask = .false.)))&
, 'int32 check 7')
call check( all( abs( cov(x2, 1) - reshape([&
60._dp/9, 60._dp/9, 30._dp/9&
,60._dp/9, 60._dp/9, 30._dp/9&
,30._dp/9, 30._dp/9, 15._dp/9]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int32 check 8')
call check( all( abs( cov(x2, 2) - reshape([&
19._dp, 16.5_dp, 14._dp, 11.5_dp, 16.5_dp, 129._dp/9&
,109.5_dp/9, 10._dp, 14._dp, 109.5_dp/9, 93._dp/9&
, 8.5_dp, 11.5_dp, 10._dp, 8.5_dp, 7._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int32 check 9')
call check( all( abs( cov(x2, 1, corrected=.false.) - reshape([&
60._dp/9, 60._dp/9, 30._dp/9&
,60._dp/9, 60._dp/9, 30._dp/9&
,30._dp/9, 30._dp/9, 15._dp/9]&
*(size(x2, 1)-1._dp)/size(x2, 1)&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int32 check 10')
call check( all( abs( cov(x2, 2, corrected=.false.) - reshape([&
19._dp, 16.5_dp, 14._dp, 11.5_dp, 16.5_dp, 129._dp/9&
,109.5_dp/9, 10._dp, 14._dp, 109.5_dp/9, 93._dp/9&
, 8.5_dp, 11.5_dp, 10._dp, 8.5_dp, 7._dp]&
*(size(x2, 2)-1._dp)/size(x2, 2)&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int32 check 11')
call check( any(ieee_is_nan(cov(x2, 1, mask = x2 < 10)))&
, 'int32 check 12')
call check( all( abs( cov(x2, 1, mask = x2 < 11) - reshape([&
60._dp/9, 60._dp/9, 1._dp, 60._dp/9, 60._dp/9, 1._dp&
, 1._dp, 1._dp, 0.5_dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int32 check 13')
call check( all( abs( cov(x2, 2, mask = x2 < 11) - reshape([&
19._dp, 16.5_dp, 0.5_dp, 0.5_dp, 16.5_dp&
,129._dp/9, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp&
,0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int32 check 14')
call check( all( abs( cov(x2, 1, mask = x2 < 11, corrected = .false.) -&
reshape([&
5._dp, 5._dp, 0.5_dp, 5._dp, 5._dp, 0.5_dp, 0.5_dp,&
0.5_dp, 0.25_dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int32 check 15')
call check( all( abs( cov(x2, 2, mask = x2 < 11, corrected = .false.) -&
reshape([&
114._dp/9, 11._dp, 0.25_dp, 0.25_dp, 11._dp, 86._dp/9,&
0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp,&
0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int32 check 16')
call check( all( abs( cov(x2, 1, mask = x2 < 1000) - cov(x2, 1))&
< dptol)&
, 'int32 check 17')
call check( all( abs( cov(x2, 2, mask = x2 < 1000) - cov(x2, 2))&
< dptol)&
, 'int32 check 18')
end subroutine test_int32
subroutine test_int64(x, x2)
integer(int64), intent(in) :: x(:)
integer(int64), intent(in) :: x2(:, :)
call check( abs(cov(x, 1) - 2.5_dp) < dptol&
, 'int64 check 1')
call check( ieee_is_nan(cov(x, 1, .false.))&
, 'int64 check 2')
call check( ieee_is_nan((cov(x, 1, x == 1)))&
, 'int64 check 3')
call check( abs(cov(x, 1, x < 5) - 5._dp/3) < dptol&
, 'int64 check 4')
call check( abs(cov(x, 1, x < 5, corrected = .false.) -&
5._dp/4) < dptol&
, 'int64 check 5')
call check( any(ieee_is_nan(cov(x2, 1, mask = .false.)))&
, 'int64 check 6')
call check( any(ieee_is_nan(cov(x2, 2, mask = .false.)))&
, 'int64 check 7')
call check( all( abs( cov(x2, 1) - reshape([&
60._dp/9, 60._dp/9, 30._dp/9&
,60._dp/9, 60._dp/9, 30._dp/9&
,30._dp/9, 30._dp/9, 15._dp/9]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int64 check 8')
call check( all( abs( cov(x2, 2) - reshape([&
19._dp, 16.5_dp, 14._dp, 11.5_dp, 16.5_dp, 129._dp/9&
,109.5_dp/9, 10._dp, 14._dp, 109.5_dp/9, 93._dp/9&
, 8.5_dp, 11.5_dp, 10._dp, 8.5_dp, 7._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int64 check 9')
call check( all( abs( cov(x2, 1, corrected=.false.) - reshape([&
60._dp/9, 60._dp/9, 30._dp/9&
,60._dp/9, 60._dp/9, 30._dp/9&
,30._dp/9, 30._dp/9, 15._dp/9]&
*(size(x2, 1)-1._dp)/size(x2, 1)&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int64 check 10')
call check( all( abs( cov(x2, 2, corrected=.false.) - reshape([&
19._dp, 16.5_dp, 14._dp, 11.5_dp, 16.5_dp, 129._dp/9&
,109.5_dp/9, 10._dp, 14._dp, 109.5_dp/9, 93._dp/9&
, 8.5_dp, 11.5_dp, 10._dp, 8.5_dp, 7._dp]&
*(size(x2, 2)-1._dp)/size(x2, 2)&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int64 check 11')
call check( any(ieee_is_nan(cov(x2, 1, mask = x2 < 10)))&
, 'int64 check 12')
call check( all( abs( cov(x2, 1, mask = x2 < 11) - reshape([&
60._dp/9, 60._dp/9, 1._dp, 60._dp/9, 60._dp/9, 1._dp&
, 1._dp, 1._dp, 0.5_dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int64 check 13')
call check( all( abs( cov(x2, 2, mask = x2 < 11) - reshape([&
19._dp, 16.5_dp, 0.5_dp, 0.5_dp, 16.5_dp&
,129._dp/9, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp&
,0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp, 0.5_dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int64 check 14')
call check( all( abs( cov(x2, 1, mask = x2 < 11, corrected = .false.) -&
reshape([&
5._dp, 5._dp, 0.5_dp, 5._dp, 5._dp, 0.5_dp, 0.5_dp,&
0.5_dp, 0.25_dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int64 check 15')
call check( all( abs( cov(x2, 2, mask = x2 < 11, corrected = .false.) -&
reshape([&
114._dp/9, 11._dp, 0.25_dp, 0.25_dp, 11._dp, 86._dp/9,&
0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp,&
0.25_dp, 0.25_dp, 0.25_dp, 0.25_dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int64 check 16')
call check( all( abs( cov(x2, 1, mask = x2 < 1000) - cov(x2, 1))&
< dptol)&
, 'int64 check 17')
call check( all( abs( cov(x2, 2, mask = x2 < 1000) - cov(x2, 2))&
< dptol)&
, 'int64 check 18')
end subroutine test_int64
subroutine test_csp(x, x2)
complex(sp), intent(in) :: x(:)
complex(sp), intent(in) :: x2(:, :)
! complex(sp), allocatable :: cd(:,:)
call check( abs(cov(x, dim=1) -&
(var(real(x),1) + var(aimag(x), 1)) ) < sptol&
, 'csp check 1')
call check( abs(cov(x, 1, aimag(x) == 0) -&
var(real(x), 1, aimag(x) == 0)) < sptol&
, 'csp check 2')
call check( abs(cov(x, dim=1, corrected=.false.) -&
(var(real(x), dim=1, corrected=.false.) +&
var(aimag(x), dim=1, corrected=.false.))) <&
sptol&
, 'csp check 3')
call check( ieee_is_nan(real(cov(x, 1, .false., corrected=.false.)))&
, 'csp check 4')
call check( abs(cov(x, 1, aimag(x) == 0, corrected=.false.) -&
var(real(x), 1, aimag(x) == 0,&
corrected=.false.)) < sptol&
, 'csp check 5')
call check( all( abs( cov(x2, 1) - reshape([&
(2.5_sp,0._sp), (5.5_sp,-1._sp), (8.5_sp,-2._sp)&
, (5.5_sp,1._sp), (12.5_sp,0._sp), (19.5_sp,-1._sp)&
, (8.5_sp,2._sp), (19.5_sp,1._sp), (30.5_sp,0._sp)]&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'csp check 6')
call check( all( abs( cov(x2, 2) - reshape([&
(4._sp,0._sp), (0._sp,4._sp),&
(0._sp,-4._sp), (4._sp,0._sp)]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'csp check 7')
call check( all( abs( cov(x2, 1, corrected=.false.) - reshape([&
(2.5_sp,0._sp), (5.5_sp,-1._sp), (8.5_sp,-2._sp)&
, (5.5_sp,1._sp), (12.5_sp,0._sp), (19.5_sp,-1._sp)&
, (8.5_sp,2._sp), (19.5_sp,1._sp), (30.5_sp,0._sp)]&
*(size(x2, 1)-1._sp)/size(x2, 1)&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'csp check 8')
call check( all( abs( cov(x2, 2, corrected=.false.) - reshape([&
(4._sp,0._sp), (0._sp,4._sp),&
(0._sp,-4._sp), (4._sp,0._sp)]&
*(size(x2, 2)-1._sp)/size(x2, 2)&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'csp check 9')
! Issue with gfortran 7 and 8: do not extract cd(1:2, 1:2) correctly
! allocate(cd, source = cov(x2, 1, mask = aimag(x2) < 6))
! call check( all( abs( cd(1:2, 1:2) - reshape([&
! (2.5_sp,0._sp), (5.5_sp,-1._sp)&
! ,(5.5_sp,1._sp), (12.5_sp,0._sp)]&
! ,[2, 2])&
! ) < sptol)&
! , 'csp check 10')
! call check( ieee_is_nan(real(cd(3,3)))&
! , 'csp check 10 bis')
call check( all( abs( cov(x2, 1, mask = aimag(x2) < 8) - cov(x2, 1))&
< sptol)&
, 'csp check 11')
call check( all( abs( cov(x2, 2, mask = aimag(x2) < 8) - cov(x2, 2))&
< sptol)&
, 'csp check 12')
call check( all( abs( cov(x2, 2, mask = aimag(x2) < 6) - reshape([&
(4._sp,0._sp), (0._sp,2._sp)&
,(0._sp,-2._sp), (2._sp,0._sp)]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'csp check 13')
call check( all( abs( cov(x2, 2, mask = aimag(x2) < 6, corrected = .false.) -&
reshape([&
(2.6666666666666666_sp,0._sp), (0._sp,1._sp)&
,(0._sp,-1._sp), (1._sp,0._sp)]&
,[ size(x2, 1), size(x2, 1)])&
) < sp)&
, 'csp check 14')
end subroutine test_csp
subroutine test_cdp(x, x2)
complex(dp), intent(in) :: x(:)
complex(dp), intent(in) :: x2(:, :)
! complex(dp), allocatable :: cd(:,:)
call check( abs(cov(x, dim=1) -&
(var(real(x),1) + var(aimag(x), 1)) ) < dptol&
, 'cdp check 1')
call check( abs(cov(x, 1, aimag(x) == 0) -&
var(real(x), 1, aimag(x) == 0)) < dptol&
, 'cdp check 2')
call check( abs(cov(x, dim=1, corrected=.false.) -&
(var(real(x), dim=1, corrected=.false.) +&
var(aimag(x), dim=1, corrected=.false.))) <&
dptol&
, 'cdp check 3')
call check( ieee_is_nan(real(cov(x, 1, .false., corrected=.false.)))&
, 'cdp check 4')
call check( abs(cov(x, 1, aimag(x) == 0, corrected=.false.) -&
var(real(x), 1, aimag(x) == 0,&
corrected=.false.)) < dptol&
, 'cdp check 5')
call check( all( abs( cov(x2, 1) - reshape([&
(2.5_dp,0._dp), (5.5_dp,-1._dp), (8.5_dp,-2._dp)&
, (5.5_dp,1._dp), (12.5_dp,0._dp), (19.5_dp,-1._dp)&
, (8.5_dp,2._dp), (19.5_dp,1._dp), (30.5_dp,0._dp)]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'cdp check 6')
call check( all( abs( cov(x2, 2) - reshape([&
(4._dp,0._dp), (0._dp,4._dp),&
(0._dp,-4._dp), (4._dp,0._dp)]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'cdp check 7')
call check( all( abs( cov(x2, 1, corrected=.false.) - reshape([&
(2.5_dp,0._dp), (5.5_dp,-1._dp), (8.5_dp,-2._dp)&
, (5.5_dp,1._dp), (12.5_dp,0._dp), (19.5_dp,-1._dp)&
, (8.5_dp,2._dp), (19.5_dp,1._dp), (30.5_dp,0._dp)]&
*(size(x2, 1)-1._dp)/size(x2, 1)&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'cdp check 8')
call check( all( abs( cov(x2, 2, corrected=.false.) - reshape([&
(4._dp,0._dp), (0._dp,4._dp),&
(0._dp,-4._dp), (4._dp,0._dp)]&
*(size(x2, 2)-1._dp)/size(x2, 2)&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'cdp check 9')
! Issue with gfortran 7 and 8: do not extract cd(1:2, 1:2) correctly
! allocate(cd, source = cov(x2, 1, mask = aimag(x2) < 6))
!
! call check( all( abs( cd(1:2, 1:2) - reshape([&
! (2.5_dp,0._dp), (5.5_dp,-1._dp)&
! ,(5.5_dp,1._dp), (12.5_dp,0._dp)]&
! ,[2, 2])&
! ) < dptol)&
! , 'cdp check 10')
! call check( ieee_is_nan(real(cd(3,3)))&
! , 'cdp check 10 bis')
call check( all( abs( cov(x2, 1, mask = aimag(x2) < 8) - cov(x2, 1))&
< dptol)&
, 'cdp check 11')
call check( all( abs( cov(x2, 2, mask = aimag(x2) < 8) - cov(x2, 2))&
< dptol)&
, 'cdp check 12')
call check( all( abs( cov(x2, 2, mask = aimag(x2) < 6) - reshape([&
(4._dp,0._dp), (0._dp,2._dp)&
,(0._dp,-2._dp), (2._dp,0._dp)]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'cdp check 13')
call check( all( abs( cov(x2, 2, mask = aimag(x2) < 6, corrected = .false.) -&
reshape([&
(2.6666666666666666_dp,0._dp), (0._dp,1._dp)&
,(0._dp,-1._dp), (1._dp,0._dp)]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'cdp check 14')
end subroutine test_cdp
end program test_cov
fortran-lang-stdlib-0ede301/test/stats/test_varn.f90 0000664 0001750 0001750 00000056202 15135654166 022635 0 ustar alastair alastair module test_varn
use, intrinsic :: ieee_arithmetic, only: ieee_is_nan
use stdlib_kinds, only: sp, dp, int32
use stdlib_stats, only: var
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_varn, initialize_test_data
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
integer(int32) :: i321(5) = [1, 2, 3, 4, 5]
integer(int32), allocatable :: i32(:,:), i323(:,:,:)
real(sp) :: s1(5) = [1._sp, 2._sp, 3._sp, 4._sp, 5._sp]
real(dp) :: d1(5) = [1._dp, 2._dp, 3._dp, 4._dp, 5._dp]
real(sp), allocatable :: s(:,:), s3(:,:,:)
real(dp), allocatable :: d3(:,:,:)
real(dp) :: d(4,3) = reshape([1._dp, 3._dp, 5._dp, 7._dp, &
2._dp, 4._dp, 6._dp, 8._dp, &
9._dp, 10._dp, 11._dp, 12._dp], [4, 3])
complex(dp) :: cd1(5) = [(0.57706_dp, 0.00000_dp), &
(0.00000_dp, 1.44065_dp), &
(1.26401_dp, 0.00000_dp), &
(0.00000_dp, 0.88833_dp), &
(1.14352_dp, 0.00000_dp)]
complex(dp) :: cd(5,3)
contains
subroutine initialize_test_data()
s = d
i32 = d
allocate(s3(size(s, 1),size(s, 2),3))
s3(:,:,1) = s
s3(:,:,2) = s * 2
s3(:,:,3) = s * 4
allocate(d3(size(d, 1),size(d, 2),3))
d3(:,:,1) = d
d3(:,:,2) = d * 2
d3(:,:,3) = d * 4
allocate(i323(size(i32, 1),size(i32, 2),3))
i323(:,:,1) = i32
i323(:,:,2) = i32 * 2
i323(:,:,3) = i32 * 4
cd(:,1) = cd1
cd(:,2) = cd1 * 3_sp
cd(:,3) = cd1 * 1.5_sp
end subroutine initialize_test_data
!> Collect all exported unit tests
subroutine collect_varn(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('varn_sp_1dim', test_sp_1dim), &
new_unittest('varn_sp_1dim_mask', test_sp_1dim_mask), &
new_unittest('varn_sp_1dim_mask_array', test_sp_1dim_mask_array), &
new_unittest('varn_sp_2dim', test_sp_2dim), &
new_unittest('varn_sp_2dim_mask', test_sp_2dim_mask), &
new_unittest('varn_sp_2dim_mask_array', test_sp_2dim_mask_array), &
new_unittest('varn_sp_3dim', test_sp_3dim), &
new_unittest('varn_sp_3dim_mask', test_sp_3dim_mask), &
new_unittest('varn_sp_3dim_mask_array', test_sp_3dim_mask_array), &
new_unittest('varn_dp_1dim', test_dp_1dim), &
new_unittest('varn_dp_1dim_mask', test_dp_1dim_mask), &
new_unittest('varn_dp_1dim_mask_array', test_dp_1dim_mask_array), &
new_unittest('varn_dp_2dim', test_dp_2dim), &
new_unittest('varn_dp_2dim_mask', test_dp_2dim_mask), &
new_unittest('varn_dp_2dim_mask_array', test_dp_2dim_mask_array), &
new_unittest('varn_dp_3dim', test_dp_3dim), &
new_unittest('varn_dp_3dim_mask', test_dp_3dim_mask), &
new_unittest('varn_dp_3dim_mask_array', test_dp_3dim_mask_array), &
new_unittest('varn_int32_1dim', test_int32_1dim), &
new_unittest('varn_int32_1dim_mask', test_int32_1dim_mask), &
new_unittest('varn_int32_1dim_mask_array', test_int32_1dim_mask_array), &
new_unittest('varn_int32_2dim', test_int32_2dim), &
new_unittest('varn_int32_2dim_mask', test_int32_2dim_mask), &
new_unittest('varn_int32_2dim_mask_array', test_int32_2dim_mask_array), &
new_unittest('varn_int32_3dim', test_int32_3dim), &
new_unittest('varn_int32_3dim_mask', test_int32_3dim_mask), &
new_unittest('varn_int32_3dim_mask_array', test_int32_3dim_mask_array), &
new_unittest('varn_cdp_1dim', test_cdp_1dim), &
new_unittest('varn_cdp_1dim_mask', test_cdp_1dim_mask), &
new_unittest('varn_cdp_1dim_mask_array', test_cdp_1dim_mask_array), &
new_unittest('varn_cdp_2dim', test_cdp_2dim), &
new_unittest('varn_cdp_2dim_mask', test_cdp_2dim_mask), &
new_unittest('varn_cdp_2dim_mask_array', test_cdp_2dim_mask_array) &
]
end
subroutine test_sp_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s1, corrected=.false.) - 2.5*(4./5.)) < sptol)
call check(error, abs(var(s1, dim=1, corrected=.false.) - 2.5*(4./5.)) < sptol)
end
subroutine test_sp_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(s1, .false., corrected=.false.)))
call check(error, ieee_is_nan(var(s1, 1, .false., corrected=.false.)))
end
subroutine test_sp_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s1, s1 < 5, corrected=.false.) - 5./4.) < sptol)
call check(error, ieee_is_nan((var(s1, s1 < 0., corrected=.false.))))
call check(error, abs(var(s1, s1 == 1., corrected=.false.)) < sptol)
call check(error, abs(var(s1, 1, s1 < 5, corrected=.false.) - 5./4.) < sptol)
end
subroutine test_sp_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s, corrected=.false.) - 13.*11./12.) < sptol)
call check(error, all(abs(var(s, 1, corrected=.false.) &
- [20., 20., 5.]/4.) < sptol))
call check(error, all(abs(var(s, 2, corrected=.false.) &
- [19., 43./3., 31./ 3., 7.0]*2./3.) < sptol))
end
subroutine test_sp_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(s, .false., corrected=.false.)))
call check(error, any(ieee_is_nan(var(s, 1, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(s, 2, .false., corrected=.false.))))
end
subroutine test_sp_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s, s < 11, corrected=.false.) - 2.75*3.) < sptol)
call check(error, all(abs(var(s, 1, s < 11, corrected=.false.) &
- [5., 5., 0.25]) < sptol))
call check(error, all(abs(var(s, 2, s < 11, corrected=.false.) &
- [19.0*2./3., 43./9.*2., 0.25 , 0.25]) < sptol))
end
subroutine test_sp_3dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s3, corrected=.false.) - 153.4*35./36.) < sptol)
call check(error, all(abs(var(s3, 1, corrected=.false.) -&
reshape([20. / 3., 20. / 3., 5. / 3.,&
4* 20. / 3., 4* 20. / 3., 4* 5. / 3.,&
16* 20. / 3., 16* 20. / 3., 16* 5. / 3.],&
[size(s3, 2), size(s3, 3)])*3./4.)&
< sptol))
call check(error, all(abs(var(s3, 2, corrected=.false.) -&
reshape([19.0, 43. / 3., 31. / 3. , 7.0,&
4* 19.0, 4* 43. / 3., 4* 31. / 3. , 4* 7.0,&
16* 19.0, 16* 43. / 3., 16* 31. / 3. , 16* 7.0],&
[size(s3, 1), size(s3, 3)])*2./3.)&
< sptol))
call check(error, all(abs(var(s3, 3, corrected=.false.) -&
reshape([ 7./3., 21., 175./3.,&
343./3., 28./3., 112./3.,&
84., 448./3., 189.,&
700./3., 847./3., 336.], [size(s3,1), size(s3,2)] )*2./3.)&
< sptol))
end
subroutine test_sp_3dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(s3, .false., corrected=.false.)))
call check(error, any(ieee_is_nan(var(s3, 1, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(s3, 2, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(s3, 3, .false., corrected=.false.))))
end
subroutine test_sp_3dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s3, s3 < 11, corrected=.false.) - 7.73702383_sp) < sptol)
call check(error, all( abs( var(s3, 1, s3 < 45, corrected=.false.) -&
reshape([5., 5., 1.25, 20., 20., 5., 80., 80., 32./3.],&
[size(s3, 2), size(s3, 3)])) < sptol ))
call check(error, all( abs( var(s3, 2, s3 < 45, corrected=.false.) -&
reshape([ 38./3., 86./9., 6.88888931, 14./3., 152./3.,&
38.2222214, 27.5555573, 18.6666660, 202.666672,&
152.888885, 110.222229, 4.&
],&
[size(s3, 1), size(s3, 3)])) < sptol ))
call check(error, all( abs( var(s3, 3, s3 < 45, corrected=.false.) -&
reshape([1.555555, 14., 38.888888, 76.222222, 6.2222222,&
24.888888, 56., 99.5555, 126., 155.555555, 188.22222, 36.&
], [size(s3,1), size(s3,2)] ))&
< sptol ))
end
subroutine test_dp_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
call check(error, abs(var(d1, dim=1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
end
subroutine test_dp_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(d1, .false., corrected=.false.)))
call check(error, ieee_is_nan(var(d1, 1, .false., corrected=.false.)))
end
subroutine test_dp_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d1, d1 < 5, corrected=.false.) - 5._dp/4.) < dptol)
call check(error, ieee_is_nan((var(d1, d1 < 0, corrected=.false.))))
call check(error, abs(var(d1, d1 == 1, corrected=.false.)) < dptol)
call check(error, abs(var(d1, 1, d1 < 5, corrected=.false.) - 5._dp/4.) < dptol)
end
subroutine test_dp_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d, corrected=.false.) - 13._dp*11./12.) < dptol)
call check(error, all( abs( var(d, 1, corrected=.false.) - [20., 20., 5.]/4._dp) < dptol))
call check(error, all( abs( var(d, 2, corrected=.false.) -&
[38._dp, 86._dp / 3._dp, 62._dp / 3._dp , 14._dp]/3._dp) < dptol))
end
subroutine test_dp_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(d, .false., corrected=.false.)))
call check(error, any(ieee_is_nan(var(d, 1, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(d, 2, .false., corrected=.false.))))
end
subroutine test_dp_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d, d < 11, corrected=.false.) - 2.75_dp*3._dp) < dptol)
call check(error, all( abs( var(d, 1, d < 11, corrected=.false.) -&
[5._dp, 5._dp, 0.25_dp]) < dptol))
call check(error, all( abs( var(d, 2, d < 11, corrected=.false.) -&
[38._dp/3., 86._dp/9., 0.25_dp , 0.25_dp]) < dptol))
end
subroutine test_dp_3dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d3, corrected=.false.) - 153.4_dp*35._dp/36._dp) < dptol)
call check(error, all( abs( var(d3, 1, corrected=.false.) -&
reshape([20._dp , 20._dp , 5._dp ,&
4* 20._dp , 4* 20._dp , 4* 5._dp ,&
16* 20._dp , 16* 20._dp , 16* 5._dp ],&
[size(d3,2), size(d3,3)])/4._dp)&
< dptol))
call check(error, all( abs( var(d3, 2, corrected=.false.) -&
reshape([38._dp, 86. / 3._dp, 62. / 3._dp , 14._dp,&
8* 19._dp, 8* 43. / 3._dp, 8* 31. / 3._dp, 8* 7._dp,&
32* 19._dp, 32* 43. / 3._dp, 32* 31. / 3._dp, 32* 7._dp],&
[size(d3,1), size(d3,3)] )/3._dp)&
< dptol))
call check(error, all(abs( var(d3, 3, corrected=.false.) -&
reshape([7._dp/3., 21._dp, 175._dp/3.,&
343._dp/3., 28._dp/3., 112._dp/3.,&
84._dp, 448._dp/3., 189._dp,&
700._dp/3., 847._dp/3., 336._dp],&
[size(d3, 1), size(d3, 2)] )*2._dp/3._dp)&
< dptol))
end
subroutine test_dp_3dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(d3, .false., corrected=.false.)))
call check(error, any(ieee_is_nan(var(d3, 1, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(d3, 2, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(d3, 3, .false., corrected=.false.))))
end
subroutine test_dp_3dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d3, d3 < 11, corrected=.false.) -&
7.7370242214532876_dp) < dptol)
call check(error, all(abs(var(d3, 1, d3 < 45, corrected=.false.) -&
reshape([5._dp, 5._dp, 1.25_dp, 20._dp, 20._dp, 5._dp,&
80._dp, 80._dp, 32._dp/3.],&
[size(d3, 2), size(d3, 3)])) < dptol))
call check(error, all(abs( var(d3, 2, d3 < 45, corrected=.false.) -&
reshape([38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
1376._dp/9., 992._dp/9., 4._dp&
],&
[size(d3, 1), size(d3, 3)])) < dptol))
call check(error, all(abs(var(d3, 3, d3 < 45, corrected=.false.) -&
reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
1694._dp/9., 36._dp&
], [size(d3, 1), size(d3, 2)]))&
< dptol ))
end
subroutine test_int32_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i321, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
call check(error, abs(var(i321, dim=1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
end
subroutine test_int32_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i321, .false., corrected=.false.)))
call check(error, ieee_is_nan(var(i321, 1, .false., corrected=.false.)))
end
subroutine test_int32_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i321, i321 < 5, corrected=.false.) - 5._dp/4.) < dptol)
call check(error, ieee_is_nan((var(i321, i321 < 0, corrected=.false.))))
call check(error, abs(var(i321, i321 == 1, corrected=.false.)) < dptol)
call check(error, abs(var(i321, 1, i321 < 5, corrected=.false.) - 5._dp/4.) < dptol)
end
subroutine test_int32_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i32, corrected=.false.) - 13._dp*11./12.) < dptol)
call check(error, all(abs(var(i32, 1, corrected=.false.) -&
[20., 20., 5.]/4._dp) < dptol))
call check(error, all(abs(var(i32, 2, corrected=.false.) -&
[38._dp, 86._dp / 3._dp, 62._dp / 3._dp , 14._dp]/3._dp) < dptol))
end
subroutine test_int32_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i32, .false., corrected=.false.)))
call check(error, any(ieee_is_nan(var(i32, 1, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(i32, 2, .false., corrected=.false.))))
end
subroutine test_int32_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i32, i32 < 11, corrected=.false.) - 2.75_dp*3._dp) < dptol)
call check(error, all(abs(var(i32, 1, i32 < 11, corrected=.false.) -&
[5._dp, 5._dp, 0.25_dp]) < dptol))
call check(error, all(abs(var(i32, 2, i32 < 11, corrected=.false.) -&
[38._dp/3., 86._dp/9., 0.25_dp , 0.25_dp]) < dptol))
end
subroutine test_int32_3dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i323, corrected=.false.) - 153.4_dp*35._dp/36._dp) < dptol)
call check(error, all(abs(var(i323, 1, corrected=.false.) -&
reshape([20._dp , 20._dp , 5._dp ,&
4* 20._dp , 4* 20._dp , 4* 5._dp ,&
16* 20._dp , 16* 20._dp , 16* 5._dp ],&
[size(i323,2), size(i323,3)])/4._dp)&
< dptol))
call check(error, all(abs(var(i323, 2, corrected=.false.) -&
reshape([38._dp, 86. / 3._dp, 62. / 3._dp , 14._dp,&
8* 19._dp, 8* 43. / 3._dp, 8* 31. / 3._dp, 8* 7._dp,&
32* 19._dp, 32* 43. / 3._dp, 32* 31. / 3._dp, 32* 7._dp],&
[size(i323,1), size(i323,3)] )/3._dp)&
< dptol))
call check(error, all(abs(var(i323, 3, corrected=.false.) -&
reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
343._dp/3., 28._dp/3., 112._dp/3.,&
84._dp, 448._dp/3., 189._dp,&
700._dp/3., 847._dp/3., 336._dp],&
[size(i323,1), size(i323,2)] )*2._dp/3._dp)&
< dptol))
end
subroutine test_int32_3dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i323, .false., corrected=.false.)))
call check(error, any(ieee_is_nan(var(i323, 1, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(i323, 2, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(i323, 3, .false., corrected=.false.))))
end
subroutine test_int32_3dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i323, i323 < 11, corrected=.false.) -&
7.7370242214532876_dp) < dptol)
call check(error, all(abs(var(i323, 1, i323 < 45, corrected=.false.) -&
reshape([5._dp, 5._dp, 1.25_dp, 20._dp, 20._dp, 5._dp,&
80._dp, 80._dp, 32._dp/3.],&
[size(i323, 2), size(i323, 3)])) < dptol ))
call check(error, all(abs(var(i323, 2, i323 < 45, corrected=.false.) -&
reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
1376._dp/9., 992._dp/9., 4._dp&
],&
[size(i323, 1), size(i323, 3)])) < dptol ))
call check(error, all(abs(var(i323, 3, i323 < 45, corrected=.false.) -&
reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
1694._dp/9., 36._dp&
], [size(i323,1), size(i323,2)] ))&
< dptol ))
end
subroutine test_cdp_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cd1, corrected=.false.) -&
(var(real(cd1), corrected=.false.) +&
var(aimag(cd1), corrected=.false.))) < dptol)
call check(error, abs(var(cd1, dim=1, corrected=.false.) -&
(var(real(cd1), dim=1, corrected=.false.) +&
var(aimag(cd1), dim=1, corrected=.false.))) < dptol)
end
subroutine test_cdp_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(cd1, .false., corrected=.false.)))
call check(error, ieee_is_nan(var(cd1, 1, .false., corrected=.false.)))
end
subroutine test_cdp_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cd1, cd1%im == 0, corrected=.false.) &
- var(cd1%re, cd1%im == 0, corrected=.false.)) < dptol)
call check(error, abs(var(cd1, 1, cd1%im == 0, corrected=.false.) &
- var(cd1%re, 1, cd1%im == 0, corrected=.false.)) < dptol)
call check(error, ieee_is_nan((var(cd1, all([cd1%re, cd1%im] == 0), &
corrected=.false.))))
call check(error, abs(var(cd1, (cd1%re > 1.2 .and. cd1%im == 0), &
corrected=.false.)) < dptol)
end
subroutine test_cdp_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cd, corrected=.false.) &
- (var(cd%re, corrected=.false.) &
+ var(cd%im, corrected=.false.))) < dptol)
call check(error, all(abs(var(cd, 1, corrected=.false.) &
- (var(cd%re, 1, corrected=.false.) &
+ var(cd%im, 1, corrected=.false.))) < dptol))
call check(error, all(abs(var(cd, 2, corrected=.false.) &
- (var(cd%re, 2, corrected=.false.) &
+ var(cd%im, 2, corrected=.false.))) < dptol))
end
subroutine test_cdp_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(cd, .false., corrected=.false.)))
call check(error, any(ieee_is_nan(var(cd, 1, .false., corrected=.false.))))
call check(error, any(ieee_is_nan(var(cd, 2, .false., corrected=.false.))))
end
subroutine test_cdp_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cd, cd%im == 0, corrected=.false.) &
- var(cd%re, cd%im == 0, corrected=.false.)) < dptol)
call check(error, all(abs(var(cd, 1, cd%im == 0, corrected=.false.) &
- var(cd%re, 1, cd%im == 0, corrected=.false.)) < dptol))
call check(error, any(ieee_is_nan(var(cd, 2, cd%im == 0, corrected=.false.))))
end
end module test_varn
program tester
use, intrinsic :: iso_fortran_env, only: error_unit
use testdrive, only: run_testsuite, new_testsuite, testsuite_type
use test_varn, only: collect_varn, initialize_test_data
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite('varn', collect_varn) &
]
call initialize_test_data()
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/stats/test_random.f90 0000664 0001750 0001750 00000010445 15135654166 023146 0 ustar alastair alastair module test_stats_random
use stdlib_kinds, only: int8, int16, int32, int64
use stdlib_random, only : random_seed, dist_rand
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_stats_random
contains
!> Collect all exported unit tests
subroutine collect_stats_random(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("random_seed", test_random_seed), &
new_unittest("random_rand_iint8", test_random_rand_iint8), &
new_unittest("random_rand_iint16", test_random_rand_iint8), &
new_unittest("random_rand_iint32", test_random_rand_iint8), &
new_unittest("random_rand_iint64", test_random_rand_iint8) &
]
end subroutine collect_stats_random
subroutine test_random_seed(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: put, get, res(5)
integer :: ans(5) = [-1859553078, -1933696596, -642834430, &
1711399314, 1548311463]
integer :: i
put = 135792468
do i = 1, 5
call random_seed(put, get)
res(i) = get
put = get
end do
call check(error, all(res == ans))
end subroutine test_random_seed
subroutine test_random_rand_iint8(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: put, get, i
integer(int8) :: res(5), ans(5) = [118, -15, -72, 101, 70]
put = 12345678
call random_seed(put, get)
do i = 1, 5
res(i) = dist_rand(1_int8)
end do
call check(error, all(res == ans))
end subroutine test_random_rand_iint8
subroutine test_random_rand_iint16(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: put, get, i
integer(int16) :: res(5), ans(5) = [30286, -3799, -18204, 25947, 18148]
put = 12345678
call random_seed(put, get)
do i = 1, 5
res(i) = dist_rand(1_int16)
end do
call check(error, all(res == ans))
end subroutine test_random_rand_iint16
subroutine test_random_rand_iint32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: put, get, i
integer(int32) :: res(5), ans(5)=[1984865646, -248954393, -1192993267, &
1700514835, 1189401802]
put = 12345678
call random_seed(put, get)
do i = 1, 5
res(i) = dist_rand(1_int32)
end do
call check(error, all(res == ans))
end subroutine test_random_rand_iint32
subroutine test_random_rand_iint64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: put, get, i
integer(int64) :: res(5), ans(5)=[8524933037632333570_int64, &
-1069250973542918798_int64, &
-5123867065024149335_int64, &
7303655603304982073_int64, &
5108441843522503546_int64]
put = 12345678
call random_seed(put, get)
do i = 1, 5
res(i) = dist_rand(1_int64)
end do
call check(error, all(res == ans))
end subroutine test_random_rand_iint64
end module test_stats_random
program tester
use iso_fortran_env, only: error_unit
use testdrive, only: new_testsuite, run_testsuite, testsuite_type
use test_stats_random, only: collect_stats_random
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("stats_random", collect_stats_random) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/stats/test_mean.fypp 0000664 0001750 0001750 00000037174 15135654166 023176 0 ustar alastair alastair #:include "common.fypp"
#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES
#:set NRANK = 4
module test_stats_mean
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_stats, only: mean
use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, xdp, qp
use, intrinsic :: ieee_arithmetic, only : ieee_is_nan
implicit none
private
public :: collect_stats_mean
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 2000 * epsilon(1._dp)
#:if WITH_XDP
real(xdp), parameter :: xdptol = 2000 * epsilon(1._xdp)
#:endif
#:if WITH_QP
real(qp), parameter :: qptol = 2000 * epsilon(1._qp)
#:endif
#:for k1,t1 in IR_KINDS_TYPES
${t1}$ , parameter :: d1_${k1}$(18) = [-10, 2, 3, 4, -6, 6, -7, 8, 9, 4, 1, -20, 9, 10, 14, 15, 40, 30]
${t1}$ :: d2_${k1}$(3, 6) = reshape(d1_${k1}$, [3, 6])
${t1}$ :: d3_${k1}$(3, 2, 3) = reshape(d1_${k1}$, [3, 2, 3])
${t1}$ :: d4_${k1}$(3, 2, 3, 2) = reshape(d1_${k1}$, [3, 2, 3, 2], [${t1}$ :: 3])
#:endfor
#:for k1,t1 in CMPLX_KINDS_TYPES
${t1}$ , parameter :: d1_c${k1}$(18) = d1_${k1}$
${t1}$ :: d2_c${k1}$(3, 6) = reshape(d1_c${k1}$, [3, 6])
${t1}$ :: d3_c${k1}$(3, 2, 3) = reshape(d1_c${k1}$, [3, 2, 3])
${t1}$ :: d4_c${k1}$(3, 2, 3, 2) = reshape(d1_c${k1}$, [3, 2, 3, 2], [${t1}$ :: (3, -2)] )
#:endfor
contains
!> Collect all exported unit tests
subroutine collect_stats_mean(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("test_stats_mean_all_int8", test_stats_mean_all_int8) &
#:for k1,t1 in IR_KINDS_TYPES
,new_unittest("test_stats_mean_all_${k1}$", test_stats_mean_all_${k1}$) &
, new_unittest("test_stats_mean_all_optmask_${k1}$", test_stats_mean_all_optmask_${k1}$) &
, new_unittest("test_stats_mean_${k1}$", test_stats_mean_${k1}$) &
, new_unittest("test_stats_mean_optmask_${k1}$", test_stats_mean_optmask_${k1}$) &
, new_unittest("test_stats_mean_mask_all_${k1}$", test_stats_mean_mask_all_${k1}$) &
, new_unittest("test_stats_mean_mask_${k1}$", test_stats_mean_mask_${k1}$) &
#:endfor
#:for k1,t1 in CMPLX_KINDS_TYPES
,new_unittest("test_stats_mean_all_c${k1}$", test_stats_mean_all_c${k1}$) &
, new_unittest("test_stats_mean_all_optmask_c${k1}$", test_stats_mean_all_optmask_c${k1}$) &
, new_unittest("test_stats_mean_c${k1}$", test_stats_mean_c${k1}$) &
, new_unittest("test_stats_mean_optmask_c${k1}$", test_stats_mean_optmask_c${k1}$) &
, new_unittest("test_stats_mean_mask_all_c${k1}$", test_stats_mean_mask_all_c${k1}$) &
, new_unittest("test_stats_mean_mask_c${k1}$", test_stats_mean_mask_c${k1}$) &
#:endfor
]
end subroutine collect_stats_mean
#:for k1,t1 in INT_KINDS_TYPES
subroutine test_stats_mean_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK + 1)
call check(error, mean(d${rank}$_${k1}$), sum(real(d${rank}$_${k1}$, dp))/real(size(d${rank}$_${k1}$), dp)&
, 'mean(d${rank}$_${k1}$): uncorrect answer'&
, thr = dptol)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_all_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK + 1)
call check(error, ieee_is_nan(mean(d${rank}$_${k1}$, .false.))&
, 'mean(d${rank}$_${k1}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error&
, abs(mean(d1_${k1}$, 1) -&
sum(real(d1_${k1}$, dp), 1)/real(size(d1_${k1}$, 1), dp)) < dptol&
, 'mean(d1_${k1}$, 1): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error&
, sum(abs(mean(d${rank}$_${k1}$, ${dim}$) -&
sum(real(d${rank}$_${k1}$, dp), ${dim}$)/real(size(d${rank}$_${k1}$, ${dim}$), dp))) < dptol&
, 'mean(d${rank}$_${k1}$, ${dim}$): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
subroutine test_stats_mean_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(mean(d1_${k1}$, 1, .false.))&
, 'mean(d1_${k1}$, 1, .false.): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error, any(ieee_is_nan(mean(d${rank}$_${k1}$, ${dim}$, .false.)))&
, 'mean(d${rank}$_${k1}$, ${dim}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
subroutine test_stats_mean_mask_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK+1)
call check(error, mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)&
, sum(real(d${rank}$_${k1}$, dp), d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0), dp)&
, 'mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0): uncorrect answer'&
, thr = dptol)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_mask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error&
, abs(mean(d1_${k1}$, 1, d1_${k1}$ > 0) -&
sum(real(d1_${k1}$, dp), 1, d1_${k1}$ > 0)/real(count(d1_${k1}$ > 0, 1), dp)) < dptol&
, 'mean(d1_${k1}$, 1, d1_${k1}$ > 0): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error&
, sum(abs(mean(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0) -&
sum(real(d${rank}$_${k1}$, dp), ${dim}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0, ${dim}$), dp))) < dptol&
, 'mean(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
#:endfor
#:for k1,t1 in REAL_KINDS_TYPES
subroutine test_stats_mean_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK+1)
call check(error, mean(d${rank}$_${k1}$), sum(d${rank}$_${k1}$)/real(size(d${rank}$_${k1}$), ${k1}$)&
, 'mean(d${rank}$_${k1}$): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_all_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK+1)
call check(error, ieee_is_nan(mean(d${rank}$_${k1}$, .false.))&
, 'mean(d${rank}$_${k1}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error&
, abs(mean(d1_${k1}$, 1) - sum(d1_${k1}$, 1)/real(size(d1_${k1}$, 1), ${k1}$)) <${k1}$tol&
, 'mean(d1_${k1}$, 1): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error&
, sum(abs(mean(d${rank}$_${k1}$, ${dim}$) -&
sum(d${rank}$_${k1}$, ${dim}$)/real(size(d${rank}$_${k1}$, ${dim}$), ${k1}$))) < ${k1}$tol&
, 'mean(d${rank}$_${k1}$, ${dim}$): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
subroutine test_stats_mean_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(mean(d1_${k1}$, 1, .false.))&
, 'mean(d1_${k1}$, 1, .false.): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error, any(ieee_is_nan(mean(d${rank}$_${k1}$, ${dim}$, .false.)))&
, 'mean(d${rank}$_${k1}$, ${dim}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
subroutine test_stats_mean_mask_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK+1)
call check(error, mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)&
, sum(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0), ${k1}$)&
, 'mean(d${rank}$_${k1}$, d${rank}$_${k1}$ > 0): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_mask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error&
, abs(mean(d1_${k1}$, 1, d1_${k1}$ > 0) -&
sum(d1_${k1}$, 1, d1_${k1}$ > 0)/real(count(d1_${k1}$ > 0, 1), ${k1}$)) < ${k1}$tol&
, 'mean(d1_${k1}$, 1, d1_${k1}$ > 0): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error&
, sum(abs(mean(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0) -&
sum(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0)/real(count(d${rank}$_${k1}$ > 0, ${dim}$), ${k1}$))) < ${k1}$tol&
, 'mean(d${rank}$_${k1}$, ${dim}$, d${rank}$_${k1}$ > 0): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
#:endfor
#:for k1,t1 in CMPLX_KINDS_TYPES
subroutine test_stats_mean_all_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK+1)
call check(error, mean(d${rank}$_c${k1}$), sum(d${rank}$_c${k1}$)/real(size(d${rank}$_c${k1}$), ${k1}$)&
, 'mean(d${rank}$_c${k1}$): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_all_optmask_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK+1)
call check(error, ieee_is_nan(real(mean(d${rank}$_c${k1}$, .false.)))&
, 'mean(d${rank}$_c${k1}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error&
, abs(mean(d1_c${k1}$, 1) - sum(d1_c${k1}$, 1)/real(size(d1_c${k1}$, 1), ${k1}$)) <${k1}$tol&
, 'mean(d1_c${k1}$, 1): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error&
, sum(abs(mean(d${rank}$_c${k1}$, ${dim}$) -&
sum(d${rank}$_c${k1}$, ${dim}$)/real(size(d${rank}$_c${k1}$, ${dim}$), ${k1}$))) < ${k1}$tol&
, 'mean(d${rank}$_c${k1}$, ${dim}$): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
subroutine test_stats_mean_optmask_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(real(mean(d1_c${k1}$, 1, .false.)))&
, 'mean(d1_c${k1}$, 1, .false.): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error, any(ieee_is_nan(real(mean(d${rank}$_c${k1}$, ${dim}$, .false.))))&
, 'mean(d${rank}$_c${k1}$, ${dim}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
subroutine test_stats_mean_mask_all_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:for rank in range(1, NRANK+1)
call check(error, mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0)&
, sum(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0)/real(count(d${rank}$_c${k1}$%re > 0), ${k1}$)&
, 'mean(d${rank}$_c${k1}$, d${rank}$_c${k1}$%re > 0): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:endfor
end subroutine
subroutine test_stats_mean_mask_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error&
, abs(mean(d1_c${k1}$, 1, d1_c${k1}$%re > 0) -&
sum(d1_c${k1}$, 1, d1_c${k1}$%re > 0)/real(count(d1_c${k1}$%re > 0, 1), ${k1}$)) < ${k1}$tol&
, 'mean(d1_c${k1}$, 1, d1_c${k1}$%re > 0): uncorrect answer'&
)
if (allocated(error)) return
#:for rank in range(2, NRANK+1)
#:for dim in range(1, rank+1)
call check(error&
, sum(abs(mean(d${rank}$_c${k1}$, ${dim}$, d${rank}$_c${k1}$%re > 0) -&
sum(d${rank}$_c${k1}$, ${dim}$, d${rank}$_c${k1}$%re > 0)/real(count(d${rank}$_c${k1}$%re > 0, ${dim}$), ${k1}$))) < ${k1}$tol&
, 'mean(d${rank}$_c${k1}$, ${dim}$, d${rank}$_c${k1}$%re > 0): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:endfor
end subroutine
#:endfor
end module test_stats_mean
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_stats_mean, only : collect_stats_mean
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("stats_mean", collect_stats_mean) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/stats/CMakeLists.txt 0000664 0001750 0001750 00000001305 15135654166 023042 0 ustar alastair alastair #### Pre-process: .fpp -> .f90 via Fypp
# Create a list of the files to be preprocessed
set(fppFiles
test_mean.fypp
test_mean_f03.fypp
test_median.fypp
test_distribution_uniform.fypp
test_distribution_normal.fypp
test_distribution_exponential.fypp
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(corr)
ADDTEST(cov)
ADDTEST(mean)
ADDTEST(median)
ADDTEST(moment)
ADDTEST(rawmoment)
ADDTEST(var)
ADDTEST(varn)
ADDTEST(random)
ADDTEST(distribution_uniform)
ADDTEST(distribution_normal)
ADDTEST(distribution_exponential)
if(DEFINED CMAKE_MAXIMUM_RANK)
if(${CMAKE_MAXIMUM_RANK} GREATER 7)
ADDTEST(mean_f03)
endif()
elseif(f03rank)
ADDTEST(mean_f03)
endif()
fortran-lang-stdlib-0ede301/test/stats/test_corr.f90 0000664 0001750 0001750 00000037404 15135654166 022637 0 ustar alastair alastair program test_corr
use stdlib_error, only: check
use stdlib_kinds, only: sp, dp, int32, int64
use stdlib_stats, only: corr
use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
implicit none
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
real(dp) :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp]
real(dp) :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 22._dp,&
3._dp, 4._dp, 6._dp, 20._dp,&
15._dp, 14._dp, 13._dp, 12._dp], [4, 3])
complex(dp) :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp, kind = dp),&
cmplx(0.00000_dp, 1.44065_dp, kind = dp),&
cmplx(1.26401_dp, 0.00000_dp, kind = dp),&
cmplx(0.00000_dp, 0.88833_dp, kind = dp),&
cmplx(1.14352_dp, 0.00000_dp, kind = dp)]
complex(dp) :: ds(2,3) = reshape([ cmplx(1._dp, 0._dp, kind = dp),&
cmplx(0._dp, 2._dp, kind = dp),&
cmplx(3._dp, 0._dp, kind = dp),&
cmplx(0._dp, 4._dp, kind = dp),&
cmplx(5._dp, 0._dp, kind = dp),&
cmplx(0._dp, 6._dp, kind = dp)], [2, 3])
call test_sp(real(d1, sp), real(d, sp))
call test_dp(d1,d)
call test_int32(int(d1, int32) ,int(d, int32))
call test_int64(int(d1, int64) ,int(d, int64))
call test_csp(cmplx(cd1, kind = sp), cmplx(ds, kind = sp))
call test_cdp(cd1, ds)
contains
subroutine test_sp(x, x2)
real(sp), intent(in) :: x(:)
real(sp), intent(in) :: x2(:, :)
call check( abs(corr(x, 1) - 1._sp) < sptol&
, 'sp check 1')
call check( ieee_is_nan(corr(x, 1, .false.))&
, 'sp check 2')
call check( ieee_is_nan(corr(x, 1, x == 1.)), 'sp check 3')
call check( abs(corr(x, 1, x < 5) - 1._sp) < sptol, 'sp check 4')
call check( ieee_is_nan(corr(x, 1, x < -999)), 'sp check 5')
call check( any(ieee_is_nan(corr(x2, 1, mask = .false.)))&
, 'sp check 6')
call check( any(ieee_is_nan(corr(x2, 2, mask = .false.)))&
, 'sp check 7')
call check( all( abs( corr(x2, 1) - reshape([&
1._sp, 0.9994439103600_sp, -0.870544389237152_sp, 0.99944391036_sp,&
1._sp, -0.86261576629742_sp, -0.87054438923715_sp, -0.862615766297428_sp,&
1._sp ]&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'sp check 8')
call check( all( abs( corr(x2, 2) - reshape([&
1._sp, 0.998742137866914_sp, 0.999846989517886_sp, -0.998337488459582_sp,&
0.998742137866914_sp, 1._sp, 0.999466429486246_sp, -0.99419162560192020_sp,&
0.999846989517886_sp, 0.999466429486246_sp, 1._sp, -0.99717646495273815_sp,&
-0.998337488459582_sp, -0.994191625601920_sp, -0.997176464952738_sp, 1._sp]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'sp check 9')
call check( any(ieee_is_nan(corr(x2, 1, mask = x2 < 10)))&
, 'sp check 10')
call check( all( abs( corr(x2, 1, mask = x2 < 22) - reshape([&
1._sp, 0.981980506061965_sp, -1._sp&
,0.981980506061965_sp, 1._sp, -0.862615766297428_sp&
,-1._sp, -0.862615766297428_sp, 1._sp]&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'sp check 11')
call check( all( abs( corr(x2, 2, mask = x2 < 22) - reshape([&
1._sp, 0.998742137866914_sp, 0.999846989517886_sp, -1._sp&
,0.998742137866914_sp, 1._sp, 0.999466429486246_sp, -1._sp&
,0.999846989517886_sp, 0.999466429486246_sp, 1._sp, -1._sp&
,-1._sp, -1._sp, -1._sp, 1._sp]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'sp check 12')
call check( all(abs(corr(x2, 1, mask = x2 < 1000) - corr(x2, 1))&
< sptol)&
, 'sp check 13')
call check( all(abs(corr(x2, 2, mask = x2 < 1000) - corr(x2, 2))&
< sptol)&
, 'sp check 14')
end subroutine test_sp
subroutine test_dp(x, x2)
real(dp), intent(in) :: x(:)
real(dp), intent(in) :: x2(:, :)
call check( abs(corr(x, 1) - 1._dp) < dptol&
, 'dp check 1')
call check( ieee_is_nan(corr(x, 1, .false.))&
, 'dp check 2')
call check( ieee_is_nan(corr(x, 1, x == 1.)), 'dp check 3')
call check( abs(corr(x, 1, x < 5) - 1._dp) < dptol, 'dp check 4')
call check( ieee_is_nan(corr(x, 1, x < -999)), 'dp check 5')
call check( any(ieee_is_nan(corr(x2, 1, mask = .false.)))&
, 'dp check 6')
call check( any(ieee_is_nan(corr(x2, 2, mask = .false.)))&
, 'dp check 7')
call check( all( abs( corr(x2, 1) - reshape([&
1._dp, 0.9994439103600_dp, -0.870544389237152_dp, 0.99944391036_dp,&
1._dp, -0.86261576629742_dp, -0.87054438923715_dp, -0.862615766297428_dp,&
1._dp ]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'dp check 8')
call check( all( abs( corr(x2, 2) - reshape([&
1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -0.998337488459582_dp,&
0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -0.99419162560192020_dp,&
0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -0.99717646495273815_dp,&
-0.998337488459582_dp, -0.994191625601920_dp, -0.997176464952738_dp, 1._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'dp check 9')
call check( any(ieee_is_nan(corr(x2, 1, mask = x2 < 10)))&
, 'dp check 10')
call check( all( abs( corr(x2, 1, mask = x2 < 22) - reshape([&
1._dp, 0.981980506061965_dp, -1._dp&
,0.981980506061965_dp, 1._dp, -0.862615766297428_dp&
,-1._dp, -0.862615766297428_dp, 1._dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'dp check 11')
call check( all( abs( corr(x2, 2, mask = x2 < 22) - reshape([&
1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -1._dp&
,0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -1._dp&
,0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -1._dp&
,-1._dp, -1._dp, -1._dp, 1._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'dp check 12')
call check( all(abs(corr(x2, 1, mask = x2 < 1000) - corr(x2, 1))&
< dptol)&
, 'dp check 13')
call check( all(abs(corr(x2, 2, mask = x2 < 1000) - corr(x2, 2))&
< dptol)&
, 'dp check 14')
end subroutine test_dp
subroutine test_int32(x, x2)
integer(int32), intent(in) :: x(:)
integer(int32), intent(in) :: x2(:, :)
call check( abs(corr(x, 1) - 1._dp) < dptol&
, 'int32 check 1')
call check( ieee_is_nan(corr(x, 1, .false.))&
, 'int32 check 2')
call check( ieee_is_nan(corr(x, 1, x == 1.)), 'int32 check 3')
call check( abs(corr(x, 1, x < 5) - 1._dp) < dptol, 'int32 check 4')
call check( ieee_is_nan(corr(x, 1, x < -999)), 'int32 check 5')
call check( any(ieee_is_nan(corr(x2, 1, mask = .false.)))&
, 'int32 check 6')
call check( any(ieee_is_nan(corr(x2, 2, mask = .false.)))&
, 'int32 check 7')
call check( all( abs( corr(x2, 1) - reshape([&
1._dp, 0.9994439103600_dp, -0.870544389237152_dp, 0.99944391036_dp,&
1._dp, -0.86261576629742_dp, -0.87054438923715_dp, -0.862615766297428_dp,&
1._dp ]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int32 check 8')
call check( all( abs( corr(x2, 2) - reshape([&
1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -0.998337488459582_dp,&
0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -0.99419162560192020_dp,&
0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -0.99717646495273815_dp,&
-0.998337488459582_dp, -0.994191625601920_dp, -0.997176464952738_dp, 1._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int32 check 9')
call check( any(ieee_is_nan(corr(x2, 1, mask = x2 < 10)))&
, 'int32 check 10')
call check( all( abs( corr(x2, 1, mask = x2 < 22) - reshape([&
1._dp, 0.981980506061965_dp, -1._dp&
,0.981980506061965_dp, 1._dp, -0.862615766297428_dp&
,-1._dp, -0.862615766297428_dp, 1._dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int32 check 11')
call check( all( abs( corr(x2, 2, mask = x2 < 22) - reshape([&
1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -1._dp&
,0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -1._dp&
,0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -1._dp&
,-1._dp, -1._dp, -1._dp, 1._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int32 check 12')
call check( all(abs(corr(x2, 1, mask = x2 < 1000) - corr(x2, 1))&
< dptol)&
, 'int32 check 13')
call check( all(abs(corr(x2, 2, mask = x2 < 1000) - corr(x2, 2))&
< dptol)&
, 'int32 check 14')
end subroutine test_int32
subroutine test_int64(x, x2)
integer(int64), intent(in) :: x(:)
integer(int64), intent(in) :: x2(:, :)
call check( abs(corr(x, 1) - 1._dp) < dptol&
, 'int64 check 1')
call check( ieee_is_nan(corr(x, 1, .false.))&
, 'int64 check 2')
call check( ieee_is_nan(corr(x, 1, x == 1)), 'int64 check 3')
call check( abs(corr(x, 1, x < 5) - 1._dp) < dptol, 'int64 check 4')
call check( ieee_is_nan(corr(x, 1, x < -999)), 'int64 check 5')
call check( any(ieee_is_nan(corr(x2, 1, mask = .false.)))&
, 'int64 check 6')
call check( any(ieee_is_nan(corr(x2, 2, mask = .false.)))&
, 'int64 check 7')
call check( all( abs( corr(x2, 1) - reshape([&
1._dp, 0.9994439103600_dp, -0.870544389237152_dp, 0.99944391036_dp,&
1._dp, -0.86261576629742_dp, -0.87054438923715_dp, -0.862615766297428_dp,&
1._dp ]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int64 check 8')
call check( all( abs( corr(x2, 2) - reshape([&
1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -0.998337488459582_dp,&
0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -0.99419162560192020_dp,&
0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -0.99717646495273815_dp,&
-0.998337488459582_dp, -0.994191625601920_dp, -0.997176464952738_dp, 1._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int64 check 9')
call check( any(ieee_is_nan(corr(x2, 1, mask = x2 < 10)))&
, 'int64 check 10')
call check( all( abs( corr(x2, 1, mask = x2 < 22) - reshape([&
1._dp, 0.981980506061965_dp, -1._dp&
,0.981980506061965_dp, 1._dp, -0.862615766297428_dp&
,-1._dp, -0.862615766297428_dp, 1._dp]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'int64 check 11')
call check( all( abs( corr(x2, 2, mask = x2 < 22) - reshape([&
1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -1._dp&
,0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -1._dp&
,0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -1._dp&
,-1._dp, -1._dp, -1._dp, 1._dp]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'int64 check 12')
call check( all(abs(corr(x2, 1, mask = x2 < 1000) - corr(x2, 1))&
< dptol)&
, 'int64 check 13')
call check( all(abs(corr(x2, 2, mask = x2 < 1000) - corr(x2, 2))&
< dptol)&
, 'int64 check 14')
end subroutine test_int64
subroutine test_csp(x, x2)
complex(sp), intent(in) :: x(:)
complex(sp), intent(in) :: x2(:, :)
call check( abs(corr(x, dim=1) - 1._sp) < sptol&
, 'csp check 1')
call check( abs(corr(x, 1, aimag(x) == 0) - 1._sp ) < sptol&
, 'csp check 2')
call check( ieee_is_nan(corr(x, 1, aimag(x) == -99 )) &
, 'csp check 3')
call check( ieee_is_nan(real(corr(x, 1, .false.)))&
, 'csp check 4')
call check( all( abs( corr(x2, 1) - reshape([&
(1._sp,0._sp), (0.983869910099907_sp,-0.178885438199983_sp),&
(0.973417168333576_sp,-0.229039333725547_sp),&
(0.983869910099907_sp,0.178885438199983_sp), (1._sp,0._sp),&
(0.998687663476588_sp,-0.051214751973158_sp),&
(0.973417168333575_sp,0.229039333725547_sp),&
(0.998687663476588_sp,0.0512147519731583_sp), (1._sp,0._sp) ]&
,[ size(x2, 2), size(x2, 2)])&
) < sptol)&
, 'csp check 6')
call check( all( abs( corr(x2, 2) - reshape([&
(1._sp,0._sp), (0._sp,1._sp),&
(0._sp,-1._sp), (1._sp,0._sp)]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'csp check 7')
call check( all( abs( corr(x2, 2, mask = aimag(x2) < 6) - reshape([&
(1._sp,0._sp), (0._sp,1._sp)&
,(0._sp,-1._sp), (1._sp,0._sp)]&
,[ size(x2, 1), size(x2, 1)])&
) < sptol)&
, 'csp check 8')
call check( all(abs(corr(x2, 1, mask = aimag(x2) < 1000) - corr(x2, 1))&
< sptol)&
, 'csp check 9')
call check( all(abs(corr(x2, 2, mask = aimag(x2) < 1000) - corr(x2, 2))&
< sptol)&
, 'csp check 10')
end subroutine test_csp
subroutine test_cdp(x, x2)
complex(dp), intent(in) :: x(:)
complex(dp), intent(in) :: x2(:, :)
call check( abs(corr(x, dim=1) - 1._dp) < dptol&
, 'cdp check 1')
call check( abs(corr(x, 1, aimag(x) == 0) - 1._dp ) < dptol&
, 'cdp check 2')
call check( ieee_is_nan(corr(x, 1, aimag(x) == -99 )) &
, 'cdp check 3')
call check( ieee_is_nan(real(corr(x, 1, .false.)))&
, 'cdp check 4')
call check( all( abs( corr(x2, 1) - reshape([&
(1._dp,0._dp), (0.983869910099907_dp,-0.178885438199983_dp),&
(0.973417168333576_dp,-0.229039333725547_dp),&
(0.983869910099907_dp,0.178885438199983_dp), (1._dp,0._dp),&
(0.998687663476588_dp,-0.051214751973158_dp),&
(0.973417168333575_dp,0.229039333725547_dp),&
(0.998687663476588_dp,0.0512147519731583_dp), (1._dp,0._dp) ]&
,[ size(x2, 2), size(x2, 2)])&
) < dptol)&
, 'cdp check 6')
call check( all( abs( corr(x2, 2) - reshape([&
(1._dp,0._dp), (0._dp,1._dp),&
(0._dp,-1._dp), (1._dp,0._dp)]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'cdp check 7')
call check( all( abs( corr(x2, 2, mask = aimag(x2) < 6) - reshape([&
(1._dp,0._dp), (0._dp,1._dp)&
,(0._dp,-1._dp), (1._dp,0._dp)]&
,[ size(x2, 1), size(x2, 1)])&
) < dptol)&
, 'cdp check 8')
call check( all(abs(corr(x2, 1, mask = aimag(x2) < 1000) - corr(x2, 1))&
< sptol)&
, 'csp check 9')
call check( all(abs(corr(x2, 2, mask = aimag(x2) < 1000) - corr(x2, 2))&
< sptol)&
, 'csp check 10')
end subroutine test_cdp
end program test_corr
fortran-lang-stdlib-0ede301/test/stats/test_distribution_exponential.fypp 0000664 0001750 0001750 00000036047 15135654166 027401 0 ustar alastair alastair
#:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
program test_distribution_expon
use stdlib_kinds, only : sp, dp, xdp, qp
use stdlib_error, only : check
use stdlib_random, only : random_seed
use stdlib_stats_distribution_exponential, only : expon_rvs => rvs_exp, &
expon_pdf => pdf_exp, expon_cdf => cdf_exp
implicit none
#:for k1, t1 in REAL_KINDS_TYPES
${t1}$, parameter :: ${k1}$tol = 1000 * epsilon(1.0_${k1}$)
#:endfor
logical :: warn = .true.
integer :: put, get
put = 12345678
call random_seed(put, get)
call test_exponential_random_generator
#:for k1, t1 in RC_KINDS_TYPES
call test_expon_rvs_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
call test_expon_pdf_${t1[0]}$${k1}$
#:endfor
call test_expon_pdf_rsp
#:for k1, t1 in RC_KINDS_TYPES
call test_expon_cdf_${t1[0]}$${k1}$
#:endfor
contains
subroutine test_exponential_random_generator
integer, parameter :: num = 10000000, array_size = 1000
integer :: i, j, freq(0:array_size)
real(dp) :: chisq, expct
print *, ""
print *, "Test exponential random generator with chi-squared"
! using interface for lambda
freq = 0
do i = 1, num
j = 1000 * (1 - exp(- expon_rvs(1.0)))
freq(j) = freq(j) + 1
end do
chisq = 0.0_dp
expct = num / array_size
do i = 0, array_size - 1
chisq = chisq + (freq(i) - expct) ** 2 / expct
end do
write(*,*) "The critical values for chi-squared with 1000 d. of f. is" &
//" 1143.92"
write(*,*) "Chi-squared for exponential random generator is : ", chisq
call check((chisq < 1143.9), &
msg="exponential randomness failed chi-squared test", warn=warn)
! using interface for loc and scale
freq = 0
do i = 1, num
j = 1000 * (1 - exp(- expon_rvs(0.0, 1.0)))
freq(j) = freq(j) + 1
end do
chisq = 0.0_dp
expct = num / array_size
do i = 0, array_size - 1
chisq = chisq + (freq(i) - expct) ** 2 / expct
end do
write(*,*) "The critical values for chi-squared with 1000 d. of f. is" &
//" 1143.92"
write(*,*) "Chi-squared for exponential random generator is : ", chisq
call check((chisq < 1143.9), &
msg="exponential randomness failed chi-squared test", warn=warn)
end subroutine test_exponential_random_generator
#:for k1, t1 in RC_KINDS_TYPES
subroutine test_expon_rvs_${t1[0]}$${k1}$
${t1}$ :: res(10), lambda, loc, scale
integer, parameter :: k = 5
integer :: i
integer :: seed, get
#:if t1[0] == "r"
#! for real type
${t1}$, parameter :: ans(10) = &
[0.609680481289574416337018192280083895_${k1}$, &
0.137541023585612635452927558314210417_${k1}$, &
0.134921508232253721063879462841820585_${k1}$, &
1.33766060689229752493171569464417802_${k1}$, &
0.111148487576340881943792737729381770_${k1}$, &
0.533951653963536868966836361020492979_${k1}$, &
1.96897428558727671799033487332053483_${k1}$, &
0.371111977992924465160247867364281152_${k1}$, &
0.811918715695663687862785688290993341_${k1}$, &
0.404637854946697868759504975362991277_${k1}$]
#:else
#! for complex type
${t1}$, parameter :: ans(10) = &
[(1.30645817419194517786503898345732266_${k1}$, &
0.158701181060322271676454874977935106_${k1}$), &
(0.289117517640543687994027420375329869_${k1}$, &
1.54345454641418945184428733997405138_${k1}$), &
(0.238175330520730461308127295134389521_${k1}$, &
0.616098062265619464192503493485184250_${k1}$), &
(4.21923061197273582426500329997257485_${k1}$, &
0.428206128453374382877209077728016710_${k1}$), &
(1.73982581934785075970596933205212874_${k1}$, &
0.466889832630805233184044202341912994_${k1}$), &
(2.22649889847873832288931745486999202_${k1}$, &
0.879109337848515628785697537331053851_${k1}$), &
(8.76802198822945553859296653951917464_${k1}$, &
0.200128045239398311139211728004738688_${k1}$), &
(0.694821947760945587572020290930855262_${k1}$, &
0.101964167346166995492113143812345625_${k1}$), &
(0.141476585024528208770330398432893829_${k1}$, &
3.989655879458742013468417133900891716E-0002_${k1}$), &
(2.10676792861163792685325850990401309_${k1}$, &
0.249356813451327473065187125310051027_${k1}$)]
#:endif
print *, "Test exponential_distribution_rvs_${t1[0]}$${k1}$"
seed = 593742186
! set args
#:if t1[0] == "r"
#! for real type
lambda = 1.5_${k1}$
loc = 0._${k1}$
scale = 1.0_${k1}$/lambda
#:else
#! for complex type
lambda = (0.7_${k1}$, 1.3_${k1}$)
loc = (0._${k1}$, 0._${k1}$)
scale = cmplx(1.0_${k1}$/lambda%re, 1.0_${k1}$/lambda%im, kind=${k1}$)
#:endif
! tests using interface for lambda
call random_seed(seed, get)
do i = 1, k
res(i) = expon_rvs(lambda) ! 1 dummy
end do
res(6:10) = expon_rvs(lambda, k) ! 2 dummies
call check(all(abs(res - ans) < ${k1}$tol), &
msg="exponential_distribution_rvs_${t1[0]}$${k1}$ failed", warn=warn)
! tests using interface for loc and scale
call random_seed(seed, get)
do i = 1, k
res(i) = expon_rvs(loc, scale)
end do
res(6:10) = expon_rvs(loc, scale, k)
call check(all(abs(res - ans) < ${k1}$tol), &
msg="exponential_distribution_rvs_${t1[0]}$${k1}$ failed", warn=warn)
end subroutine test_expon_rvs_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
subroutine test_expon_pdf_${t1[0]}$${k1}$
${t1}$ :: x1, x2(3,4), lambda, loc, scale
integer :: seed, get
real(${k1}$) :: res(3,5)
#:if t1[0] == "r"
#! for real type
real(${k1}$), parameter :: ans(15) = &
[0.362692289054629718342313806171796533_${k1}$, &
0.362692289054629718342313806171796533_${k1}$, &
0.362692289054629718342313806171796533_${k1}$, &
1.44877092399186122284289290051705535_${k1}$, &
1.08871761038277651996081144393335589_${k1}$, &
0.203258408490339213767867275283195750_${k1}$, &
0.730004225568590859263284124264208147_${k1}$, &
0.237394827760488451509080387833146683_${k1}$, &
0.301732182586179598102005265289645959_${k1}$, &
1.35079274124711914255014934401469271_${k1}$, &
0.416578245043239337295928202660090263_${k1}$, &
1.44039177901335374382803898226703593_${k1}$, &
0.196044829271295768265275728683411055_${k1}$, &
0.271373826917613661285112379170965958_${k1}$, &
1.00108987409617105109732206933052664_${k1}$]
#:else
#! for complex type
real(${k1}$), parameter :: ans(15) = &
[0.112097715784191810518066563334849515_${k1}$, &
0.112097715784191810518066563334849515_${k1}$, &
0.112097715784191810518066563334849515_${k1}$, &
4.72087485401191174735651518020251204E-0002_${k1}$, &
3.69705018439006691768174449531170720E-0002_${k1}$, &
8.69498969681198520061798177185735738E-0002_${k1}$, &
0.128007654288233028296342302153338001_${k1}$, &
1.13496395875758374774198906169957218E-0002_${k1}$, &
0.294260498264128747413785056084385424_${k1}$, &
4.66169813179250908948018478030960097E-0002_${k1}$, &
2.84438693906889813143446828488861951E-0002_${k1}$, &
0.161859307815385236742977105439660254_${k1}$, &
4.22904796362406579112752522035325397E-0002_${k1}$, &
0.176117981883470250164040199296778089_${k1}$, &
0.107352342201327219885025541854724060_${k1}$]
#:endif
print *, "Test exponential_distribution_pdf_${t1[0]}$${k1}$"
seed = 123987654
! set args
#:if t1[0] == "r"
#! for real type
lambda = 1.5_${k1}$
loc = 0._${k1}$
scale = 1.0_${k1}$/lambda
#:else
#! for complex type
lambda = (0.3_${k1}$, 1.6_${k1}$)
loc = (0._${k1}$, 0._${k1}$)
scale = cmplx(1.0_${k1}$/lambda%re, 1.0_${k1}$/lambda%im, kind=${k1}$)
#:endif
! tests using interface for lambda
call random_seed(seed, get)
x1 = expon_rvs(lambda)
x2 = reshape(expon_rvs(lambda, 12), [3,4])
res(:,1) = expon_pdf(x1, lambda)
res(:, 2:5) = expon_pdf(x2, lambda)
call check(all(abs(res - reshape(ans, [3,5])) < ${k1}$tol), &
msg="exponential_distribution_pdf_${t1[0]}$${k1}$ failed", warn=warn)
! tests using interface for loc and scale
call random_seed(seed, get)
x1 = expon_rvs(loc, scale)
x2 = reshape(expon_rvs(loc, scale, 12), [3,4])
res(:,1) = expon_pdf(x1, loc, scale)
res(:, 2:5) = expon_pdf(x2, loc, scale)
call check(all(abs(res - reshape(ans, [3,5])) < ${k1}$tol), &
msg="exponential_distribution_pdf_${t1[0]}$${k1}$ failed", warn=warn)
end subroutine test_expon_pdf_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
subroutine test_expon_cdf_${t1[0]}$${k1}$
${t1}$ :: x1, x2(3,4), lambda, loc, scale
integer :: seed, get
real(${k1}$) :: res(3,5)
#:if t1[0] == "r"
#! for real type
real(${k1}$), parameter :: ans(15) = &
[0.109257742653704886153815776449785051_${k1}$, &
0.109257742653704886153815776449785051_${k1}$, &
0.109257742653704886153815776449785051_${k1}$, &
0.717506371795765265795319089684216215_${k1}$, &
6.82471795435370961628021592837348251E-0002_${k1}$, &
0.158022297254037860379992220663140220_${k1}$, &
0.914579543576380160727189390750289231_${k1}$, &
0.735445094339121647068624074363021598_${k1}$, &
8.69845458684957375690771394578441361E-0002_${k1}$, &
0.491195342629961409581199224477971938_${k1}$, &
0.574283568793105916250099261345264380_${k1}$, &
0.312823040527767907760475800138803955_${k1}$, &
0.640029783598040153827956625977856239_${k1}$, &
2.16202116731629451897815202649346917E-0002_${k1}$, &
7.74788145547936974757767867581111655E-0002_${k1}$]
#:else
real(${k1}$), parameter :: ans(15) = &
[7.83931265220552191922145459533155073E-0002_${k1}$, &
7.83931265220552191922145459533155073E-0002_${k1}$, &
7.83931265220552191922145459533155073E-0002_${k1}$, &
1.07845760925785109085652212151328215E-0002_${k1}$, &
0.672623038706161724678635394849362256_${k1}$, &
4.27264038113873579678831482902258168E-0002_${k1}$, &
0.179649132114996961326498233168917293_${k1}$, &
1.38375793985183014482681114776428612E-0002_${k1}$, &
3.49246365297941076158369468479748612E-0002_${k1}$, &
0.116869945417176368845403154176734792_${k1}$, &
0.468462732010133566674397830557697485_${k1}$, &
0.413506985517976634907329948218002431_${k1}$, &
0.665679674838121942273909342901808398_${k1}$, &
0.223748595107983772617787558595393205_${k1}$, &
0.337722969540396286456937689606849800_${k1}$]
#:endif
print *, "Test exponential_distribution_cdf_${t1[0]}$${k1}$"
seed = 621957438
! set args
#:if t1[0] == "r"
#! for real type
lambda = 2.0_${k1}$
loc = 0._${k1}$
scale = 1.0_${k1}$/lambda
#:else
lambda = (1.3_${k1}$, 2.1_${k1}$)
loc = (0._${k1}$, 0._${k1}$)
scale = cmplx(1.0_${k1}$/lambda%re, 1.0_${k1}$/lambda%im, kind=${k1}$)
#:endif
! tests using interface for lambda
call random_seed(seed, get)
x1 = expon_rvs(lambda)
x2 = reshape(expon_rvs(lambda, 12), [3,4])
res(:,1) = expon_cdf(x1, lambda)
res(:, 2:5) = expon_cdf(x2, lambda)
call check(all(abs(res - reshape(ans,[3,5])) < ${k1}$tol), &
msg="exponential_distribution_cdf_${t1[0]}$${k1}$ failed", warn=warn)
! tests using interface for loc and scale
call random_seed(seed, get)
x1 = expon_rvs(loc, scale)
x2 = reshape(expon_rvs(loc, scale, 12), [3,4])
res(:,1) = expon_cdf(x1, loc, scale)
res(:, 2:5) = expon_cdf(x2, loc, scale)
call check(all(abs(res - reshape(ans,[3,5])) < ${k1}$tol), &
msg="exponential_distribution_cdf_${t1[0]}$${k1}$ failed", warn=warn)
end subroutine test_expon_cdf_${t1[0]}$${k1}$
#:endfor
end program test_distribution_expon
fortran-lang-stdlib-0ede301/test/stats/test_var.f90 0000664 0001750 0001750 00000074626 15135654166 022471 0 ustar alastair alastair module test_var
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_kinds, only: sp, dp, int32, int64
use stdlib_stats, only: var
use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
implicit none
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
integer(int32), parameter :: i321(5) = [1, 2, 3, 4, 5]
integer(int64), parameter :: i641(5) = [1, 2, 3, 4, 5]
real(sp), parameter :: s1(5) = [1.0_sp, 2.0_sp, 3.0_sp, 4.0_sp, 5.0_sp]
real(dp), parameter :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp]
real(dp), parameter :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,&
2._dp, 4._dp, 6._dp, 8._dp,&
9._dp, 10._dp, 11._dp, 12._dp], [4, 3])
real(dp), parameter :: d3(4, 3, 3) = reshape([d, d*2, d*4], shape(d3))
real(sp), parameter :: s(4, 3) = d
real(sp), parameter :: s3(4, 3, 3) = reshape([s, s*2, s*4], shape(s3))
integer(int32), parameter :: i32(4, 3) = d
integer(int32), parameter :: i323(4, 3, 3) = d3
integer(int64), parameter :: i64(4, 3) = d
integer(int64), parameter :: i643(4, 3, 3) = d3
complex(sp), parameter :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp, sp),&
cmplx(0.00000_sp, 1.44065_sp, sp),&
cmplx(1.26401_sp, 0.00000_sp, sp),&
cmplx(0.00000_sp, 0.88833_sp, sp),&
cmplx(1.14352_sp, 0.00000_sp, sp)]
complex(dp), parameter :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp,kind=dp),&
cmplx(0.00000_dp, 1.44065_dp,kind=dp),&
cmplx(1.26401_dp, 0.00000_dp,kind=dp),&
cmplx(0.00000_dp, 0.88833_dp,kind=dp),&
cmplx(1.14352_dp, 0.00000_dp,kind=dp)]
complex(sp), parameter :: cs(5,3) = reshape([cs1, cs1*3.0_sp, cs1*1.5_sp], shape(cs))
complex(dp), parameter :: cd(5,3) = reshape([cd1, cd1*3.0_dp, cd1*1.5_dp], shape(cd))
contains
!> Collect all exported unit tests
subroutine collect_var(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("sp_1dim", test_sp_1dim), &
new_unittest("sp_1dim_mask", test_sp_1dim_mask), &
new_unittest("sp_2dim", test_sp_2dim), &
new_unittest("sp_2dim_mask", test_sp_2dim_mask), &
new_unittest("sp_2dim_mask_array", test_sp_2dim_mask_array), &
new_unittest("sp_3dim", test_sp_3dim), &
new_unittest("sp_3dim_mask", test_sp_3dim_mask), &
new_unittest("sp_3dim_mask_array", test_sp_3dim_mask_array), &
new_unittest("dp_1dim", test_dp_1dim), &
new_unittest("dp_1dim_mask", test_dp_1dim_mask), &
new_unittest("dp_1dim_mask_array", test_dp_1dim_mask_array), &
new_unittest("dp_2dim", test_dp_2dim), &
new_unittest("dp_2dim_mask", test_dp_2dim_mask), &
new_unittest("dp_2dim_mask_array", test_dp_2dim_mask_array), &
new_unittest("dp_3dim", test_dp_3dim), &
new_unittest("dp_3dim_mask", test_dp_3dim_mask), &
new_unittest("dp_3dim_mask_array", test_dp_3dim_mask_array), &
new_unittest("int32_1dim", test_int32_1dim), &
new_unittest("int32_1dim_mask", test_int32_1dim_mask), &
new_unittest("int32_1dim_mask_array", test_int32_1dim_mask_array), &
new_unittest("int32_2dim", test_int32_2dim), &
new_unittest("int32_2dim_mask", test_int32_2dim_mask), &
new_unittest("int32_2dim_mask_array", test_int32_2dim_mask_array), &
new_unittest("int32_3dim", test_int32_3dim), &
new_unittest("int32_3dim_mask", test_int32_3dim_mask), &
new_unittest("int32_3dim_mask_array", test_int32_3dim_mask_array), &
new_unittest("int64_1dim", test_int64_1dim), &
new_unittest("int64_1dim_mask", test_int64_1dim_mask), &
new_unittest("int641_1dim_mask_array", test_int641_1dim_mask_array), &
new_unittest("int64_2dim", test_int64_2dim), &
new_unittest("int64_2dim_mask", test_int64_2dim_mask), &
new_unittest("int64_2dim_mask_array", test_int64_2dim_mask_array), &
new_unittest("int64_3dim", test_int64_3dim), &
new_unittest("int64_3dim_mask", test_int64_3dim_mask), &
new_unittest("int64_3dim_mask_array", test_int64_3dim_mask_array), &
new_unittest("csp_1dim", test_csp_1dim), &
new_unittest("csp_1dim_mask", test_csp_1dim_mask), &
new_unittest("csp_1dim_mask_array", test_csp_1dim_mask_array), &
new_unittest("csp_2dim", test_csp_2dim), &
new_unittest("csp_2dim_mask", test_csp_2dim_mask), &
new_unittest("csp_2dim_mask_array", test_csp_2dim_mask_array), &
new_unittest("cdp_1dim", test_cdp_1dim), &
new_unittest("cdp_1dim_mask", test_cdp_1dim_mask), &
new_unittest("cdp_1dim_mask_array", test_cdp_1dim_mask_array), &
new_unittest("cdp_2dim", test_cdp_2dim), &
new_unittest("cdp_2dim_mask", test_cdp_2dim_mask), &
new_unittest("cdp_2dim_mask_array", test_cdp_2dim_mask_array) &
]
end subroutine collect_var
subroutine test_sp_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s1) - 2.5) < sptol)
call check(error, abs(var(s1, dim=1) - 2.5) < sptol)
end subroutine test_sp_1dim
subroutine test_sp_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(s1, .false.)))
call check(error, ieee_is_nan(var(s1, 1, .false.)))
end subroutine test_sp_1dim_mask
subroutine test_sp_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s1, s1 < 5) - 5./3.) < sptol)
call check(error, ieee_is_nan((var(s1, s1 < 0.))))
call check(error, ieee_is_nan((var(s1, s1 == 1.))))
call check(error, abs(var(s1, 1, s1 < 5) - 5./3.) < sptol)
end subroutine test_sp_1dim_mask_array
subroutine test_sp_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s) - 13) < sptol)
call check(error, all( abs( var(s, 1) - [20. / 3., 20. / 3., 5. / 3.]) < sptol))
call check(error, all( abs( var(s, 2) - [19.0, 43. / 3., 31. / 3. , 7.0]) < sptol))
end subroutine test_sp_2dim
subroutine test_sp_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(s, .false.)))
call check(error, any(ieee_is_nan(var(s, 1, .false.))))
call check(error, any(ieee_is_nan(var(s, 2, .false.))))
end subroutine test_sp_2dim_mask
subroutine test_sp_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s, s < 11) - 27.5 / 3.) < sptol)
call check(error, all( abs( var(s, 1, s < 11) - [20. / 3., 20. / 3., 0.5]) < sptol))
call check(error, all( abs( var(s, 2, s < 11) - [19.0, 43. / 3., 0.5 , 0.5]) < sptol))
end subroutine test_sp_2dim_mask_array
subroutine test_sp_3dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s3) - 153.4) < sptol)
call check(error, all( abs( var(s3, 1) -&
reshape([20. / 3., 20. / 3., 5. / 3.,&
4* 20. / 3., 4* 20. / 3., 4* 5. / 3.,&
16* 20. / 3., 16* 20. / 3., 16* 5. / 3.],&
[size(s3,2), size(s3,3)]))&
< sptol))
call check(error, all( abs( var(s3, 2) -&
reshape([19.0, 43. / 3., 31. / 3. , 7.0,&
4* 19.0, 4* 43. / 3., 4* 31. / 3. , 4* 7.0,&
16* 19.0, 16* 43. / 3., 16* 31. / 3. , 16* 7.0],&
[size(s3,1), size(s3,3)] ))&
< sptol))
call check(error, all(abs( var(s3, 3) -&
reshape([ 7./3., 21., 175./3.,&
343./3., 28./3., 112./3.,&
84., 448./3., 189.,&
700./3., 847./3., 336.], [size(s3,1), size(s3,2)] ))&
< sptol))
end subroutine test_sp_3dim
subroutine test_sp_3dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(s3, .false.)))
call check(error, any(ieee_is_nan(var(s3, 1, .false.))))
call check(error, any(ieee_is_nan(var(s3, 2, .false.))))
call check(error, any(ieee_is_nan(var(s3, 3, .false.))))
end subroutine test_sp_3dim_mask
subroutine test_sp_3dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(s3, s3 < 11) - 8.2205877_sp) < sptol)
call check(error, all( abs( var(s3, 1, s3 < 45) -&
reshape([20./3., 20./3., 5./3., 80./3., 80./3., 20./3.,&
320./3., 320./3., 16.],&
[size(s3, 2), size(s3, 3)])) < sptol ))
call check(error, any( ieee_is_nan( var(s3, 2, s3 < 25))))
call check(error, all( abs( var(s3, 3, s3 < 25) -&
reshape([ 7./3., 21., 175./3.,&
24.5, 28./3., 112./3.,&
84., 32., 40.5,&
50., 60.5, 72.], [size(s3,1), size(s3,2)] ))&
< sptol ))
end subroutine test_sp_3dim_mask_array
subroutine test_dp_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d1) - 2.5) < dptol)
call check(error, abs(var(d1, 1) - 2.5) < dptol)
end subroutine test_dp_1dim
subroutine test_dp_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(d1, .false.)))
call check(error, ieee_is_nan(var(d1, 1, .false.)))
end subroutine test_dp_1dim_mask
subroutine test_dp_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d1, d1 < 5) - 5._dp/3._dp) < dptol)
call check(error, ieee_is_nan((var(d1, d1 < 0.))))
call check(error, ieee_is_nan((var(d1, d1 == 1.))))
call check(error, abs(var(d1, 1, d1 < 5) - 5._dp/3._dp) < dptol)
end subroutine test_dp_1dim_mask_array
subroutine test_dp_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d) - 13) < dptol)
call check(error, all( abs( var(d,1) -&
[20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
call check(error, all( abs( var(d,2) -&
[19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))
end subroutine test_dp_2dim
subroutine test_dp_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(d, .false.)))
call check(error, any(ieee_is_nan(var(d, 1, .false.))))
call check(error, any(ieee_is_nan(var(d, 2, .false.))))
end subroutine test_dp_2dim_mask
subroutine test_dp_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d, d < 11) - 27.5_dp / 3._dp) < dptol)
call check(error, all( abs( var(d, 1, d < 11) -&
[20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
call check(error, all( abs( var(d, 2, d < 11) -&
[19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))
end subroutine test_dp_2dim_mask_array
subroutine test_dp_3dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d3) - 153.4_dp) < dptol)
call check(error, all( abs( var(d3, 1) -&
reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,&
4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,&
16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],&
[size(d3,2), size(d3,3)]))&
< dptol))
call check(error, all( abs( var(d3, 2) -&
reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,&
4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,&
16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,&
16* 7.0_dp],&
[size(d3,1), size(d3,3)] ))&
< dptol))
call check(error, all(abs( var(d3, 3) -&
reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,&
84._dp, 448._dp/3._dp, 189._dp,&
700._dp/3._dp, 847._dp/3._dp, 336._dp],&
[size(d3,1), size(d3,2)] ))&
< dptol))
end subroutine test_dp_3dim
subroutine test_dp_3dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(d3, .false.)))
call check(error, any(ieee_is_nan(var(d3, 1, .false.))))
call check(error, any(ieee_is_nan(var(d3, 2, .false.))))
call check(error, any(ieee_is_nan(var(d3, 3, .false.))))
end subroutine test_dp_3dim_mask
subroutine test_dp_3dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(d3, d3 < 25) - 46.041379310344823_dp) < dptol)
call check(error, all( abs( var(d3, 1, d3 < 45) -&
reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,&
80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,&
320._dp/3._dp, 320._dp/3._dp, 16._dp],&
[size(d3, 2), size(d3, 3)]))&
< dptol ))
call check(error, any( ieee_is_nan( var(d3, 2, d3 < 25))))
call check(error, all( abs( var(d3, 3, d3 < 25) -&
reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
24.5_dp, 28._dp/3._dp, 112._dp/3._dp,&
84._dp, 32._dp, 40.5_dp,&
50._dp, 60.5_dp, 72._dp],&
[size(d3,1), size(d3,2)] ))&
< dptol ))
end subroutine test_dp_3dim_mask_array
subroutine test_int32_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i321) - 2.5) < dptol)
call check(error, abs(var(i321, 1) - 2.5) < dptol)
end subroutine test_int32_1dim
subroutine test_int32_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i321, .false.)))
call check(error, ieee_is_nan(var(i321, 1, .false.)))
end subroutine test_int32_1dim_mask
subroutine test_int32_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i321, i321 < 5) - 5._dp/3._dp) < dptol)
call check(error, ieee_is_nan((var(i321, i321 < 0))))
call check(error, ieee_is_nan((var(i321, i321 == 1))))
call check(error, abs(var(i321, 1, i321 < 5) - 5._dp/3._dp) < dptol)
end subroutine test_int32_1dim_mask_array
subroutine test_int32_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i32) - 13) < dptol)
call check(error, all( abs( var(i32,1) -&
[20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
call check(error, all( abs( var(i32,2) -&
[19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))
end subroutine test_int32_2dim
subroutine test_int32_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i32, .false.)))
call check(error, any(ieee_is_nan(var(i32, 1, .false.))))
call check(error, any(ieee_is_nan(var(i32, 2, .false.))))
end subroutine test_int32_2dim_mask
subroutine test_int32_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i32, i32 < 11) - 27.5_dp / 3._dp) < dptol)
call check(error, all( abs( var(i32, 1, i32 < 11) -&
[20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
call check(error, all( abs( var(i32, 2, i32 < 11) -&
[19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))
end subroutine test_int32_2dim_mask_array
subroutine test_int32_3dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i323) - 153.4_dp) < dptol)
call check(error, all( abs( var(i323, 1) -&
reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,&
4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,&
16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],&
[size(i323,2), size(i323,3)]))&
< dptol))
call check(error, all( abs( var(i323, 2) -&
reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,&
4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,&
16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,&
16* 7.0_dp],&
[size(i323,1), size(i323,3)] ))&
< dptol))
call check(error, all(abs( var(i323, 3) -&
reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,&
84._dp, 448._dp/3._dp, 189._dp,&
700._dp/3._dp, 847._dp/3._dp, 336._dp],&
[size(i323,1), size(i323,2)] ))&
< dptol))
end subroutine test_int32_3dim
subroutine test_int32_3dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i323, .false.)))
call check(error, any(ieee_is_nan(var(i323, 1, .false.))))
call check(error, any(ieee_is_nan(var(i323, 2, .false.))))
call check(error, any(ieee_is_nan(var(i323, 3, .false.))))
end subroutine test_int32_3dim_mask
subroutine test_int32_3dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i323, i323 < 25) - 46.041379310344823_dp) < dptol)
call check(error, all( abs( var(i323, 1, i323 < 45) -&
reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,&
80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,&
320._dp/3._dp, 320._dp/3._dp, 16._dp],&
[size(i323, 2), size(i323, 3)]))&
< dptol ))
call check(error, any( ieee_is_nan( var(i323, 2, i323 < 25))))
call check(error, all( abs( var(i323, 3, i323 < 25) -&
reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
24.5_dp, 28._dp/3._dp, 112._dp/3._dp,&
84._dp, 32._dp, 40.5_dp,&
50._dp, 60.5_dp, 72._dp],&
[size(i323,1), size(i323,2)] ))&
< dptol ))
end subroutine test_int32_3dim_mask_array
subroutine test_int64_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i641) - 2.5) < dptol)
call check(error, abs(var(i641, 1) - 2.5) < dptol)
end subroutine test_int64_1dim
subroutine test_int64_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i641, .false.)))
call check(error, ieee_is_nan(var(i641, 1, .false.)))
end subroutine test_int64_1dim_mask
subroutine test_int641_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i641, i641 < 5) - 5._dp/3._dp) < dptol)
call check(error, ieee_is_nan((var(i641, i641 < 0))))
call check(error, ieee_is_nan((var(i641, i641 == 1))))
call check(error, abs(var(i641, 1, i641 < 5) - 5._dp/3._dp) < dptol)
end subroutine test_int641_1dim_mask_array
subroutine test_int64_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i64) - 13) < dptol)
call check(error, all( abs( var(i64,1) -&
[20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
call check(error, all( abs( var(i64,2) -&
[19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))
end subroutine test_int64_2dim
subroutine test_int64_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i64, .false.)))
call check(error, any(ieee_is_nan(var(i64, 1, .false.))))
call check(error, any(ieee_is_nan(var(i64, 2, .false.))))
end subroutine test_int64_2dim_mask
subroutine test_int64_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i64, i64 < 11) - 27.5_dp / 3._dp) < dptol)
call check(error, all( abs( var(i64, 1, i64 < 11) -&
[20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
call check(error, all( abs( var(i64, 2, i64 < 11) -&
[19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))
end subroutine test_int64_2dim_mask_array
subroutine test_int64_3dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i643) - 153.4_dp) < dptol)
call check(error, all( abs( var(i643, 1) -&
reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,&
4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,&
16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],&
[size(i643,2), size(i643,3)]))&
< dptol))
call check(error, all( abs( var(i643, 2) -&
reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,&
4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,&
16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,&
16* 7.0_dp],&
[size(i643,1), size(i643,3)] ))&
< dptol))
call check(error, all(abs( var(i643, 3) -&
reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,&
84._dp, 448._dp/3._dp, 189._dp,&
700._dp/3._dp, 847._dp/3._dp, 336._dp],&
[size(i643,1), size(i643,2)] ))&
< dptol))
end subroutine test_int64_3dim
subroutine test_int64_3dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(i643, .false.)))
call check(error, any(ieee_is_nan(var(i643, 1, .false.))))
call check(error, any(ieee_is_nan(var(i643, 2, .false.))))
call check(error, any(ieee_is_nan(var(i643, 3, .false.))))
end subroutine test_int64_3dim_mask
subroutine test_int64_3dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(i643, i643 < 25) - 46.041379310344823_dp) < dptol)
call check(error, all( abs( var(i643, 1, i643 < 45) -&
reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,&
80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,&
320._dp/3._dp, 320._dp/3._dp, 16._dp],&
[size(i643, 2), size(i643, 3)]))&
< dptol ))
call check(error, any( ieee_is_nan( var(i643, 2, i643 < 25))))
call check(error, all( abs( var(i643, 3, i643 < 25) -&
reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
24.5_dp, 28._dp/3._dp, 112._dp/3._dp,&
84._dp, 32._dp, 40.5_dp,&
50._dp, 60.5_dp, 72._dp],&
[size(i643,1), size(i643,2)] ))&
< dptol ))
end subroutine test_int64_3dim_mask_array
subroutine test_csp_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cs1) - (var(real(cs1)) + var(aimag(cs1)))) < sptol)
call check(error, abs(var(cs1, dim=1) - (var(real(cs1),1) + var(aimag(cs1), 1)) ) < sptol)
end subroutine test_csp_1dim
subroutine test_csp_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(cs1, .false.)))
call check(error, ieee_is_nan(var(cs1, 1, .false.)))
end subroutine test_csp_1dim_mask
subroutine test_csp_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cs1, aimag(cs1) == 0) - var(real(cs1), aimag(cs1) == 0)) < sptol)
call check(error, abs(var(cs1, 1, aimag(cs1) == 0) - var(real(cs1), 1, aimag(cs1) == 0)) < sptol)
end subroutine test_csp_1dim_mask_array
subroutine test_csp_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cs) - (var(real(cs)) + var(aimag(cs)))) < sptol)
call check(error, all( abs( var(cs, 1) - (var(real(cs), 1) + var(aimag(cs), 1))) < sptol))
call check(error, all( abs( var(cs, 2) - (var(real(cs), 2) + var(aimag(cs), 2))) < sptol))
end subroutine test_csp_2dim
subroutine test_csp_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(cs, .false.)))
call check(error, any(ieee_is_nan(var(cs, 1, .false.))))
call check(error, any(ieee_is_nan(var(cs, 2, .false.))))
end subroutine test_csp_2dim_mask
subroutine test_csp_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cs, aimag(cs) == 0) - var(real(cs), aimag(cs) == 0)) < sptol)
call check(error, all( abs( var(cs, 1, aimag(cs) == 0) - var(real(cs), 1, aimag(cs) == 0)) < sptol))
call check(error, any( ieee_is_nan( var(cs, 2, aimag(cs) == 0))))
end subroutine test_csp_2dim_mask_array
subroutine test_cdp_1dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cd1) - (var(real(cd1)) + var(aimag(cd1)))) < dptol)
call check(error, abs(var(cd1, dim=1) - (var(real(cd1),1) + var(aimag(cd1), 1)) ) < dptol)
end subroutine test_cdp_1dim
subroutine test_cdp_1dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(cd1, .false.)))
call check(error, ieee_is_nan(var(cd1, 1, .false.)))
end subroutine test_cdp_1dim_mask
subroutine test_cdp_1dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cd1, aimag(cd1) == 0) - var(real(cd1), aimag(cd1) == 0)) < dptol)
call check(error, abs(var(cd1, 1, aimag(cd1) == 0) - var(real(cd1), 1, aimag(cd1) == 0)) < dptol)
end subroutine test_cdp_1dim_mask_array
subroutine test_cdp_2dim(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cd) - (var(real(cd)) + var(aimag(cd)))) < dptol)
call check(error, all( abs( var(cd, 1) - (var(real(cd), 1) + var(aimag(cd), 1))) < dptol))
call check(error, all( abs( var(cd, 2) - (var(real(cd), 2) + var(aimag(cd), 2))) < dptol))
end subroutine test_cdp_2dim
subroutine test_cdp_2dim_mask(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, ieee_is_nan(var(cd, .false.)))
call check(error, any(ieee_is_nan(var(cd, 1, .false.))))
call check(error, any(ieee_is_nan(var(cd, 2, .false.))))
end subroutine test_cdp_2dim_mask
subroutine test_cdp_2dim_mask_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, abs(var(cd, aimag(cd) == 0) - var(real(cd), aimag(cd) == 0)) < dptol)
call check(error, all( abs( var(cd, 1, aimag(cd) == 0) - var(real(cd), 1, aimag(cd) == 0)) < dptol))
call check(error, any( ieee_is_nan( var(cd, 2, aimag(cd) == 0))))
end subroutine test_cdp_2dim_mask_array
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_var, only : collect_var
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("var", collect_var) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/stats/test_moment.f90 0000664 0001750 0001750 00000152101 15135654166 023161 0 ustar alastair alastair module test_moment
use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
use stdlib_kinds, only: sp, dp, int32, int64
use stdlib_stats, only: moment
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_moment, initialize_test_data
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
real(dp), parameter :: d1(5) = [1._dp, 2._dp, 3._dp, 4._dp, 5._dp]
real(dp), parameter :: d(4,3) = reshape( &
[1._dp, 3._dp, 5._dp, 7._dp, &
2._dp, 4._dp, 6._dp, 8._dp, &
9._dp, 10._dp, 11._dp, 12._dp], [4, 3])
complex(dp) :: c1(5) = [(0.57706_dp, 0.00000_dp), &
(0.00000_dp, 1.44065_dp), &
(1.26401_dp, 0.00000_dp), &
(0.00000_dp, 0.88833_dp), &
(1.14352_dp, 0.00000_dp)]
complex(dp) :: c2(5,3)
real(sp) :: x1(5) = real(d1, sp)
real(sp) :: x2(4,3) = real(d, sp)
real(sp), allocatable :: x3(:,:,:)
real(dp) :: dx1(5) = d1
real(dp) :: dx2(4,3) = d
real(dp), allocatable :: dx3(:,:,:)
integer(int32) :: i1(5) = d1
integer(int32) :: i2(4,3) = d
integer(int32), allocatable :: i3(:,:,:)
integer(int64) :: di1(5) = d1
integer(int64) :: di2(4,3) = d
integer(int64), allocatable :: di3(:,:,:)
contains
subroutine initialize_test_data()
allocate(x3(size(x2, 1),size(x2, 2),3))
x3(:,:,1) = x2
x3(:,:,2) = x2 * 2
x3(:,:,3) = x2 * 4
allocate(dx3(size(dx2, 1),size(dx2, 2),3))
dx3(:,:,1) = dx2
dx3(:,:,2) = dx2 * 2
dx3(:,:,3) = dx2 * 4
i3 = x3
di3 = dx3
c2(:,1) = c1
c2(:,2) = c1 * 3
c2(:,3) = c1 * 1.5
end subroutine initialize_test_data
!> Collect all exported unit tests
subroutine collect_moment(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('moment_sp_dim1_order1', test_sp_dim1_order1), &
new_unittest('moment_sp_dim1_mask_order1', test_sp_dim1_mask_order1), &
new_unittest('moment_sp_dim1_mask_array_order1', test_sp_dim1_mask_array_order1), &
new_unittest('moment_sp_dim2_order1', test_sp_dim2_order1), &
new_unittest('moment_sp_dim2_mask_order1', test_sp_dim2_mask_order1), &
new_unittest('moment_sp_dim2_mask_array_order1', test_sp_dim2_mask_array_order1), &
new_unittest('moment_sp_dim3_order1', test_sp_dim3_order1), &
new_unittest('moment_sp_dim3_mask_order1', test_sp_dim3_mask_order1), &
new_unittest('moment_sp_dim3_mask_array_order1', test_sp_dim3_mask_array_order1), &
new_unittest('moment_sp_dim1_order2', test_sp_dim1_order2), &
new_unittest('moment_sp_dim1_mask_order2', test_sp_dim1_mask_order2), &
new_unittest('moment_sp_dim1_mask_array_order2', test_sp_dim1_mask_array_order2), &
new_unittest('moment_sp_dim2_order2', test_sp_dim2_order2), &
new_unittest('moment_sp_dim2_mask_order2', test_sp_dim2_mask_order2), &
new_unittest('moment_sp_dim2_mask_array_order2', test_sp_dim2_mask_array_order2), &
new_unittest('moment_sp_dim3_order2', test_sp_dim3_order2), &
new_unittest('moment_sp_dim3_mask_order2', test_sp_dim3_mask_order2), &
new_unittest('moment_sp_dim3_mask_array_order2', test_sp_dim3_mask_array_order2), &
new_unittest('moment_dp_dim1_order1', test_dp_dim1_order1), &
new_unittest('moment_dp_dim1_mask_order1', test_dp_dim1_mask_order1), &
new_unittest('moment_dp_dim1_mask_array_order1', test_dp_dim1_mask_array_order1), &
new_unittest('moment_dp_dim2_order1', test_dp_dim2_order1), &
new_unittest('moment_dp_dim2_mask_order1', test_dp_dim2_mask_order1), &
new_unittest('moment_dp_dim2_mask_array_order1', test_dp_dim2_mask_array_order1), &
new_unittest('moment_dp_dim3_order1', test_dp_dim3_order1), &
new_unittest('moment_dp_dim3_mask_order1', test_dp_dim3_mask_order1), &
new_unittest('moment_dp_dim3_mask_array_order1', test_dp_dim3_mask_array_order1), &
new_unittest('moment_dp_dim1_order2', test_dp_dim1_order2), &
new_unittest('moment_dp_dim1_mask_order2', test_dp_dim1_mask_order2), &
new_unittest('moment_dp_dim1_mask_array_order2', test_dp_dim1_mask_array_order2), &
new_unittest('moment_dp_dim2_order2', test_dp_dim2_order2), &
new_unittest('moment_dp_dim2_mask_order2', test_dp_dim2_mask_order2), &
new_unittest('moment_dp_dim2_mask_array_order2', test_dp_dim2_mask_array_order2), &
new_unittest('moment_dp_dim3_order2', test_dp_dim3_order2), &
new_unittest('moment_dp_dim3_mask_order2', test_dp_dim3_mask_order2), &
new_unittest('moment_dp_dim3_mask_array_order2', test_dp_dim3_mask_array_order2), &
new_unittest('moment_int32_dim1_order1', test_int32_dim1_order1), &
new_unittest('moment_int32_dim1_mask_order1', test_int32_dim1_mask_order1), &
new_unittest('moment_int32_dim1_mask_array_order1', test_int32_dim1_mask_array_order1), &
new_unittest('moment_int32_dim2_order1', test_int32_dim2_order1), &
new_unittest('moment_int32_dim2_mask_order1', test_int32_dim2_mask_order1), &
new_unittest('moment_int32_dim2_mask_array_order1', test_int32_dim2_mask_array_order1), &
new_unittest('moment_int32_dim3_order1', test_int32_dim3_order1), &
new_unittest('moment_int32_dim3_mask_order1', test_int32_dim3_mask_order1), &
new_unittest('moment_int32_dim3_mask_array_order1', test_int32_dim3_mask_array_order1), &
new_unittest('moment_int32_dim1_order2', test_int32_dim1_order2), &
new_unittest('moment_int32_dim1_mask_order2', test_int32_dim1_mask_order2), &
new_unittest('moment_int32_dim1_mask_array_order2', test_int32_dim1_mask_array_order2), &
new_unittest('moment_int32_dim2_order2', test_int32_dim2_order2), &
new_unittest('moment_int32_dim2_mask_order2', test_int32_dim2_mask_order2), &
new_unittest('moment_int32_dim2_mask_array_order2', test_int32_dim2_mask_array_order2), &
new_unittest('moment_int32_dim3_order2', test_int32_dim3_order2), &
new_unittest('moment_int32_dim3_mask_order2', test_int32_dim3_mask_order2), &
new_unittest('moment_int32_dim3_mask_array_order2', test_int32_dim3_mask_array_order2), &
new_unittest('moment_int64_dim1_order1', test_int64_dim1_order1), &
new_unittest('moment_int64_dim1_mask_order1', test_int64_dim1_mask_order1), &
new_unittest('moment_int64_dim1_mask_array_order1', test_int64_dim1_mask_array_order1), &
new_unittest('moment_int64_dim2_order1', test_int64_dim2_order1), &
new_unittest('moment_int64_dim2_mask_order1', test_int64_dim2_mask_order1), &
new_unittest('moment_int64_dim2_mask_array_order1', test_int64_dim2_mask_array_order1), &
new_unittest('moment_int64_dim3_order1', test_int64_dim3_order1), &
new_unittest('moment_int64_dim3_mask_order1', test_int64_dim3_mask_order1), &
new_unittest('moment_int64_dim3_mask_array_order1', test_int64_dim3_mask_array_order1), &
new_unittest('moment_int64_dim1_order2', test_int64_dim1_order2), &
new_unittest('moment_int64_dim1_mask_order2', test_int64_dim1_mask_order2), &
new_unittest('moment_int64_dim1_mask_array_order2', test_int64_dim1_mask_array_order2), &
new_unittest('moment_int64_dim2_order2', test_int64_dim2_order2), &
new_unittest('moment_int64_dim2_mask_order2', test_int64_dim2_mask_order2), &
new_unittest('moment_int64_dim2_mask_array_order2', test_int64_dim2_mask_array_order2), &
new_unittest('moment_int64_dim3_order2', test_int64_dim3_order2), &
new_unittest('moment_int64_dim3_mask_order2', test_int64_dim3_mask_order2), &
new_unittest('moment_int64_dim3_mask_array_order2', test_int64_dim3_mask_array_order2), &
new_unittest('moment_csp_dim1_order1', test_csp_dim1_order1), &
new_unittest('moment_csp_dim1_mask_order1', test_csp_dim1_mask_order1), &
new_unittest('moment_csp_dim1_mask_array_order1', test_csp_dim1_mask_array_order1), &
new_unittest('moment_csp_dim2_order1', test_csp_dim2_order1), &
new_unittest('moment_csp_dim2_mask_order1', test_csp_dim2_mask_order1), &
new_unittest('moment_csp_dim2_mask_array_order1', test_csp_dim2_mask_array_order1), &
new_unittest('moment_csp_dim1_order2', test_csp_dim1_order2), &
new_unittest('moment_csp_dim1_mask_order2', test_csp_dim1_mask_order2), &
new_unittest('moment_csp_dim1_mask_array_order2', test_csp_dim1_mask_array_order2), &
new_unittest('moment_csp_dim2_order2', test_csp_dim2_order2), &
new_unittest('moment_csp_dim2_mask_order2', test_csp_dim2_mask_order2), &
new_unittest('moment_csp_dim2_mask_array_order2', test_csp_dim2_mask_array_order2) &
]
end subroutine collect_moment
subroutine test_sp_dim1_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(x1, order)) < sptol)
call check(error, abs(moment(x1, order, dim=1)) < sptol)
end subroutine
subroutine test_sp_dim1_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(x1, order, mask=.false.)))
call check(error, ieee_is_nan(moment(x1, order, 1, mask=.false.)))
end subroutine
subroutine test_sp_dim1_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(x1, order, mask=(x1 < 5))) < sptol)
call check(error, abs(moment(x1, order, 1, mask=(x1 < 5))) < sptol)
end subroutine
subroutine test_sp_dim2_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(x2, order)) < sptol)
call check(error, all(abs(moment(x2, order, 1)) < sptol))
call check(error, all(abs(moment(x2, order, 2)) < sptol))
end subroutine
subroutine test_sp_dim2_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(x2, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(x2, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(x2, order, 2, mask=.false.))))
end subroutine
subroutine test_sp_dim2_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(x2, order, mask=(x2 < 11))) < sptol)
call check(error, all(abs(moment(x2, order, 1, mask=(x2 < 11))) < sptol))
call check(error, all(abs(moment(x2, order, 2, mask=(x2 < 11))) < sptol))
end subroutine
subroutine test_sp_dim3_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(x3, order)) < sptol)
call check(error, all(abs(moment(x3, order, 1)) < sptol))
call check(error, all(abs(moment(x3, order, 2)) < sptol))
call check(error, all(abs(moment(x3, order, 3)) < sptol))
end subroutine
subroutine test_sp_dim3_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(x3, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(x3, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(x3, order, 2, mask=.false.))))
call check(error, any(ieee_is_nan(moment(x3, order, 3, mask=.false.))))
end subroutine
subroutine test_sp_dim3_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(x3, order, mask=(x3 < 11)) ) < sptol)
call check(error, all(abs(moment(x3, order, 1, mask=(x3 < 45))) < sptol ))
call check(error, all(abs(moment(x3, order, 2, mask=(x3 < 45))) < sptol ))
call check(error, all(abs(moment(x3, order, 3, mask=(x3 < 45))) < sptol ))
end subroutine
subroutine test_sp_dim1_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(x1, order) - 2._sp) < sptol)
call check(error, abs(moment(x1, order, dim=1) - 2._sp) < sptol)
end subroutine
subroutine test_sp_dim1_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(x1, order, mask=.false.)))
call check(error, ieee_is_nan(moment(x1, order, 1, mask=.false.)))
end subroutine
subroutine test_sp_dim1_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(x1, order, mask=(x1 < 5)) - 1.25_sp) < sptol)
call check(error, abs(moment(x1, order, 1, mask=(x1 < 5)) - 1.25_sp) < sptol)
end subroutine
subroutine test_sp_dim2_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(x2, order) - 107.25_sp/9.) < sptol)
call check(error, all(abs(moment(x2, order, 1) - [5._sp, 5._sp, 1.25_sp]) < sptol))
call check(error, all(abs(moment(x2, order, 2) -&
[19.0, 43. / 3., 31. / 3. , 7.0]*2./3.) < sptol))
end subroutine
subroutine test_sp_dim2_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(x2, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(x2, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(x2, order, 2, mask=.false.))))
end subroutine
subroutine test_sp_dim2_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(x2, order, mask=(x2 < 11))- 2.75_sp*3.) < sptol)
call check(error, all(abs(moment(x2, order, 1, mask=(x2 < 11)) -&
[5._sp, 5._sp, 0.25_sp]) < sptol))
call check(error, all(abs(moment(x2, order, 2, mask=(x2 < 11)) -&
[19._sp*2./3., 43._sp/9.*2., 0.25_sp , 0.25_sp]) < sptol))
end subroutine
subroutine test_sp_dim3_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(x3, order) - 153.4_sp*35./36.) < sptol)
call check(error, all(abs(moment(x3, order, 1) -&
reshape([20._sp / 3., 20._sp / 3., 5._sp / 3.,&
4* 20._sp / 3., 4* 20._sp / 3., 4* 5._sp / 3.,&
16* 20._sp / 3., 16* 20._sp / 3., 16* 5._sp / 3.],&
[size(x3,2), size(x3,3)])*3._sp/4.)&
< sptol))
call check(error, all(abs(moment(x3, order, 2) -&
reshape([19._sp, 43._sp / 3., 31._sp / 3. , 7.0_sp,&
4* 19.0_sp, 4* 43._sp / 3., 4* 31._sp / 3. , 4* 7.0_sp,&
16* 19.0_sp, 16* 43._sp / 3., 16* 31._sp / 3. , 16* 7.0_sp],&
[size(x3,1), size(x3,3)] )*2._sp/3.)&
< sptol))
call check(error, all(abs(moment(x3, order, 3) -&
reshape([ 7._sp/3., 21._sp, 175._sp/3.,&
343._sp/3., 28._sp/3., 112._sp/3.,&
84._sp, 448._sp/3., 189._sp,&
700._sp/3., 847._sp/3., 336._sp],&
[size(x3,1), size(x3,2)] )*2./3.)&
< sptol))
end subroutine
subroutine test_sp_dim3_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(x3, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(x3, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(x3, order, 2, mask=.false.))))
call check(error, any(ieee_is_nan(moment(x3, order, 3, mask=.false.))))
end subroutine
subroutine test_sp_dim3_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(x3, order, mask=(x3 < 11)) -&
7.7370242214532876_dp ) < sptol)
call check(error, all(abs(moment(x3, order, 1, mask=(x3 < 45)) -&
reshape([5._sp, 5._sp, 1.25_sp, 20._sp, 20._sp, 5._sp,&
80._sp, 80._sp, 32._sp/3.],&
[size(x3, 2), size(x3, 3)])) < sptol ))
call check(error, all(abs(moment(x3, order, 2, mask=(x3 < 45)) -&
reshape([ 38._sp/3., 86._sp/9., 62._sp/9., 14._sp/3., 152._sp/3.,&
344._sp/9., 248._sp/9., 168._sp/9., 1824._sp/9.,&
1376._sp/9., 992._sp/9., 4._sp&
],&
[size(x3, 1), size(x3, 3)])) < sptol ))
call check(error, all(abs(moment(x3, order, 3, mask=(x3 < 45)) -&
reshape([14._sp/9., 14._sp, 350._sp/9., 686._sp/9., 56._sp/9.,&
224._sp/9., 56._sp, 896._sp/9., 126._sp, 1400._sp/9.,&
1694._sp/9., 36._sp&
], [size(x3,1), size(x3,2)] ))&
< sptol ))
end subroutine
subroutine test_dp_dim1_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(dx1, order)) < dptol)
call check(error, abs(moment(dx1, order, dim=1)) < dptol)
end subroutine
subroutine test_dp_dim1_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(dx1, order, mask=.false.)))
call check(error, ieee_is_nan(moment(dx1, order, 1, mask=.false.)))
end subroutine
subroutine test_dp_dim1_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(dx1, order, mask=(dx1 < 5))) < dptol)
call check(error, abs(moment(dx1, order, 1, mask=(dx1 < 5))) < dptol)
end subroutine
subroutine test_dp_dim2_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(dx2, order)) < dptol)
call check(error, all(abs(moment(dx2, order, 1)) < dptol))
call check(error, all(abs(moment(dx2, order, 2)) < dptol))
end subroutine
subroutine test_dp_dim2_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(dx2, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(dx2, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(dx2, order, 2, mask=.false.))))
end subroutine
subroutine test_dp_dim2_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(dx2, order, mask=(dx2 < 11))) < dptol)
call check(error, all(abs(moment(dx2, order, 1, mask=(dx2 < 11))) < dptol))
call check(error, all(abs(moment(dx2, order, 2, mask=(dx2 < 11))) < dptol))
end subroutine
subroutine test_dp_dim3_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(dx3, order)) < dptol)
call check(error, all(abs(moment(dx3, order, 1)) < dptol))
call check(error, all(abs(moment(dx3, order, 2)) < dptol))
call check(error, all(abs(moment(dx3, order, 3)) < dptol))
end subroutine
subroutine test_dp_dim3_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(dx3, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(dx3, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(dx3, order, 2, mask=.false.))))
call check(error, any(ieee_is_nan(moment(dx3, order, 3, mask=.false.))))
end subroutine
subroutine test_dp_dim3_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(dx3, order, mask=(dx3 < 11)) ) < dptol)
call check(error, all(abs(moment(dx3, order, 1, mask=(dx3 < 45))) < dptol ))
call check(error, all(abs(moment(dx3, order, 2, mask=(dx3 < 45))) < dptol ))
call check(error, all(abs(moment(dx3, order, 3, mask=(dx3 < 45))) < dptol ))
end subroutine
subroutine test_dp_dim1_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(dx1, order) - 2._dp) < dptol)
call check(error, abs(moment(dx1, order, dim=1) - 2._dp) < dptol)
end subroutine
subroutine test_dp_dim1_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(dx1, order, mask=.false.)))
call check(error, ieee_is_nan(moment(dx1, order, 1, mask=.false.)))
end subroutine
subroutine test_dp_dim1_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(dx1, order, mask=(dx1 < 5)) - 1.25_dp) < dptol)
call check(error, abs(moment(dx1, order, 1, mask=(dx1 < 5)) - 1.25_dp) < dptol)
end subroutine
subroutine test_dp_dim2_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(dx2, order) - 107.25_dp/9.) < dptol)
call check(error, all(abs(moment(dx2, order, 1) - [5._dp, 5._dp, 1.25_dp]) < dptol))
call check(error, all(abs(moment(dx2, order, 2) -&
[19._dp, 43._dp / 3., 31._dp / 3. , 7._dp]*2._dp/3.) < dptol))
end subroutine
subroutine test_dp_dim2_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(dx2, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(dx2, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(dx2, order, 2, mask=.false.))))
end subroutine
subroutine test_dp_dim2_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(dx2, order, mask=(dx2 < 11))- 2.75_dp*3.) < dptol)
call check(error, all(abs(moment(dx2, order, 1, mask=(dx2 < 11)) -&
[5._dp, 5._dp, 0.25_dp]) < dptol))
call check(error, all(abs(moment(dx2, order, 2, mask=(dx2 < 11)) -&
[19._dp*2./3., 43._dp/9.*2., 0.25_dp , 0.25_dp]) < dptol))
end subroutine
subroutine test_dp_dim3_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(dx3, order) - 153.4_dp*35./36.) < dptol)
call check(error, all(abs(moment(dx3, order, 1) -&
reshape([20._dp / 3., 20._dp / 3., 5._dp / 3.,&
4* 20._dp / 3., 4* 20._dp / 3., 4* 5._dp / 3.,&
16* 20._dp / 3., 16* 20._dp / 3., 16* 5._dp / 3.],&
[size(dx3,2), size(dx3,3)])*3._dp/4.)&
< dptol))
call check(error, all(abs(moment(dx3, order, 2) -&
reshape([19._dp, 43._dp / 3., 31._dp / 3. , 7.0_dp,&
4* 19.0_dp, 4* 43._dp / 3., 4* 31._dp / 3. , 4* 7.0_dp,&
16* 19.0_dp, 16* 43._dp / 3., 16* 31._dp / 3. , 16* 7.0_dp],&
[size(dx3,1), size(dx3,3)] )*2._dp/3.)&
< dptol))
call check(error, all(abs(moment(dx3, order, 3) -&
reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
343._dp/3., 28._dp/3., 112._dp/3.,&
84._dp, 448._dp/3., 189._dp,&
700._dp/3., 847._dp/3., 336._dp],&
[size(dx3,1), size(dx3,2)] )*2./3.)&
< dptol))
end subroutine
subroutine test_dp_dim3_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(dx3, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(dx3, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(dx3, order, 2, mask=.false.))))
call check(error, any(ieee_is_nan(moment(dx3, order, 3, mask=.false.))))
end subroutine
subroutine test_dp_dim3_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(dx3, order, mask=(dx3 < 11)) -&
7.7370242214532876_dp ) < dptol)
call check(error, all(abs(moment(dx3, order, 1, mask=(dx3 < 45)) -&
reshape([5._dp, 5._dp, 1.25_dp, 20._dp, 20._dp, 5._dp,&
80._dp, 80._dp, 32._dp/3.],&
[size(dx3, 2), size(dx3, 3)])) < dptol ))
call check(error, all(abs(moment(dx3, order, 2, mask=(dx3 < 45)) -&
reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
1376._dp/9., 992._dp/9., 4._dp&
],&
[size(dx3, 1), size(dx3, 3)])) < dptol ))
call check(error, all(abs(moment(dx3, order, 3, mask=(dx3 < 45)) -&
reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
1694._dp/9., 36._dp&
], [size(dx3,1), size(dx3,2)] ))&
< dptol ))
end subroutine
subroutine test_int32_dim1_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(i1, order)) < dptol)
call check(error, abs(moment(i1, order, dim=1)) < dptol)
end subroutine
subroutine test_int32_dim1_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(i1, order, mask=.false.)))
call check(error, ieee_is_nan(moment(i1, order, 1, mask=.false.)))
end subroutine
subroutine test_int32_dim1_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(i1, order, mask=(i1 < 5))) < dptol)
call check(error, abs(moment(i1, order, 1, mask=(i1 < 5))) < dptol)
end subroutine
subroutine test_int32_dim2_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(i2, order)) < dptol)
call check(error, all(abs(moment(i2, order, 1)) < dptol))
call check(error, all(abs(moment(i2, order, 2)) < dptol))
end subroutine
subroutine test_int32_dim2_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(i2, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(i2, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(i2, order, 2, mask=.false.))))
end subroutine
subroutine test_int32_dim2_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(i2, order, mask=(i2 < 11))) < dptol)
call check(error, all(abs(moment(i2, order, 1, mask=(i2 < 11))) < dptol))
call check(error, all(abs(moment(i2, order, 2, mask=(i2 < 11))) < dptol))
end subroutine
subroutine test_int32_dim3_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(i3, order)) < dptol)
call check(error, all(abs(moment(i3, order, 1)) < dptol))
call check(error, all(abs(moment(i3, order, 2)) < dptol))
call check(error, all(abs(moment(i3, order, 3)) < dptol))
end subroutine
subroutine test_int32_dim3_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(i3, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(i3, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(i3, order, 2, mask=.false.))))
call check(error, any(ieee_is_nan(moment(i3, order, 3, mask=.false.))))
end subroutine
subroutine test_int32_dim3_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(i3, order, mask=(i3 < 11)) ) < dptol)
call check(error, all(abs(moment(i3, order, 1, mask=(i3 < 45))) < dptol ))
call check(error, all(abs(moment(i3, order, 2, mask=(i3 < 45))) < dptol ))
call check(error, all(abs(moment(i3, order, 3, mask=(i3 < 45))) < dptol ))
end subroutine
subroutine test_int32_dim1_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(i1, order) - 2._dp) < dptol)
call check(error, abs(moment(i1, order, dim=1) - 2._dp) < dptol)
end subroutine
subroutine test_int32_dim1_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(i1, order, mask=.false.)))
call check(error, ieee_is_nan(moment(i1, order, 1, mask=.false.)))
end subroutine
subroutine test_int32_dim1_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(i1, order, mask=(i1 < 5)) - 1.25_dp) < dptol)
call check(error, abs(moment(i1, order, 1, mask=(i1 < 5)) - 1.25_dp) < dptol)
end subroutine
subroutine test_int32_dim2_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(i2, order) - 107.25_dp/9.) < dptol)
call check(error, all(abs(moment(i2, order, 1) - [5._dp, 5._dp, 1.25_dp]) < dptol))
call check(error, all(abs(moment(i2, order, 2) -&
[19._dp, 43._dp / 3., 31._dp / 3. , 7._dp]*2._dp/3.) < dptol))
end subroutine
subroutine test_int32_dim2_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(i2, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(i2, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(i2, order, 2, mask=.false.))))
end subroutine
subroutine test_int32_dim2_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(i2, order, mask=(i2 < 11))- 2.75_dp*3.) < dptol)
call check(error, all(abs(moment(i2, order, 1, mask=(i2 < 11)) -&
[5._dp, 5._dp, 0.25_dp]) < dptol))
call check(error, all(abs(moment(i2, order, 2, mask=(i2 < 11)) -&
[19._dp*2./3., 43._dp/9.*2., 0.25_dp , 0.25_dp]) < dptol))
end subroutine
subroutine test_int32_dim3_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(i3, order) - 153.4_dp*35./36.) < dptol)
call check(error, all(abs(moment(i3, order, 1) -&
reshape([20._dp / 3., 20._dp / 3., 5._dp / 3.,&
4* 20._dp / 3., 4* 20._dp / 3., 4* 5._dp / 3.,&
16* 20._dp / 3., 16* 20._dp / 3., 16* 5._dp / 3.],&
[size(i3,2), size(i3,3)])*3._dp/4.)&
< dptol))
call check(error, all(abs(moment(i3, order, 2) -&
reshape([19._dp, 43._dp / 3., 31._dp / 3. , 7.0_dp,&
4* 19.0_dp, 4* 43._dp / 3., 4* 31._dp / 3. , 4* 7.0_dp,&
16* 19.0_dp, 16* 43._dp / 3., 16* 31._dp / 3. , 16* 7.0_dp],&
[size(i3,1), size(i3,3)] )*2._dp/3.)&
< dptol))
call check(error, all(abs(moment(i3, order, 3) -&
reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
343._dp/3., 28._dp/3., 112._dp/3.,&
84._dp, 448._dp/3., 189._dp,&
700._dp/3., 847._dp/3., 336._dp],&
[size(i3,1), size(i3,2)] )*2./3.)&
< dptol))
end subroutine
subroutine test_int32_dim3_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(i3, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(i3, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(i3, order, 2, mask=.false.))))
call check(error, any(ieee_is_nan(moment(i3, order, 3, mask=.false.))))
end subroutine
subroutine test_int32_dim3_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(i3, order, mask=(i3 < 11)) -&
7.7370242214532876_dp ) < dptol)
call check(error, all(abs(moment(i3, order, 1, mask=(i3 < 45)) -&
reshape([5._dp, 5._dp, 1.25_dp, 20._dp, 20._dp, 5._dp,&
80._dp, 80._dp, 32._dp/3.],&
[size(i3, 2), size(i3, 3)])) < dptol ))
call check(error, all(abs(moment(i3, order, 2, mask=(i3 < 45)) -&
reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
1376._dp/9., 992._dp/9., 4._dp&
],&
[size(i3, 1), size(i3, 3)])) < dptol ))
call check(error, all(abs(moment(i3, order, 3, mask=(i3 < 45)) -&
reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
1694._dp/9., 36._dp&
], [size(i3,1), size(i3,2)] ))&
< dptol ))
end subroutine
subroutine test_int64_dim1_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(di1, order)) < dptol)
call check(error, abs(moment(di1, order, dim=1)) < dptol)
end subroutine
subroutine test_int64_dim1_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(di1, order, mask=.false.)))
call check(error, ieee_is_nan(moment(di1, order, 1, mask=.false.)))
end subroutine
subroutine test_int64_dim1_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(di1, order, mask=(di1 < 5))) < dptol)
call check(error, abs(moment(di1, order, 1, mask=(di1 < 5))) < dptol)
end subroutine
subroutine test_int64_dim2_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(di2, order)) < dptol)
call check(error, all(abs(moment(di2, order, 1)) < dptol))
call check(error, all(abs(moment(di2, order, 2)) < dptol))
end subroutine
subroutine test_int64_dim2_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(di2, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(di2, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(di2, order, 2, mask=.false.))))
end subroutine
subroutine test_int64_dim2_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(di2, order, mask=(di2 < 11))) < dptol)
call check(error, all(abs(moment(di2, order, 1, mask=(di2 < 11))) < dptol))
call check(error, all(abs(moment(di2, order, 2, mask=(di2 < 11))) < dptol))
end subroutine
subroutine test_int64_dim3_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(di3, order)) < dptol)
call check(error, all(abs(moment(di3, order, 1)) < dptol))
call check(error, all(abs(moment(di3, order, 2)) < dptol))
call check(error, all(abs(moment(di3, order, 3)) < dptol))
end subroutine
subroutine test_int64_dim3_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(moment(di3, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(di3, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(di3, order, 2, mask=.false.))))
call check(error, any(ieee_is_nan(moment(di3, order, 3, mask=.false.))))
end subroutine
subroutine test_int64_dim3_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(di3, order, mask=(di3 < 11)) ) < dptol)
call check(error, all(abs(moment(di3, order, 1, mask=(di3 < 45))) < dptol ))
call check(error, all(abs(moment(di3, order, 2, mask=(di3 < 45))) < dptol ))
call check(error, all(abs(moment(di3, order, 3, mask=(di3 < 45))) < dptol ))
end subroutine
subroutine test_int64_dim1_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(di1, order) - 2._dp) < dptol)
call check(error, abs(moment(di1, order, dim=1) - 2._dp) < dptol)
end subroutine
subroutine test_int64_dim1_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(di1, order, mask=.false.)))
call check(error, ieee_is_nan(moment(di1, order, 1, mask=.false.)))
end subroutine
subroutine test_int64_dim1_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(di1, order, mask=(di1 < 5)) - 1.25_dp) < dptol)
call check(error, abs(moment(di1, order, 1, mask=(di1 < 5)) - 1.25_dp) < dptol)
end subroutine
subroutine test_int64_dim2_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(di2, order) - 107.25_dp/9.) < dptol)
call check(error, all(abs(moment(di2, order, 1) - [5._dp, 5._dp, 1.25_dp]) < dptol))
call check(error, all(abs(moment(di2, order, 2) -&
[19._dp, 43._dp / 3., 31._dp / 3. , 7._dp]*2._dp/3.) < dptol))
end subroutine
subroutine test_int64_dim2_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(i2, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(di2, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(di2, order, 2, mask=.false.))))
end subroutine
subroutine test_int64_dim2_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(di2, order, mask=(di2 < 11))- 2.75_dp*3.) < dptol)
call check(error, all(abs(moment(di2, order, 1, mask=(di2 < 11)) -&
[5._dp, 5._dp, 0.25_dp]) < dptol))
call check(error, all(abs(moment(di2, order, 2, mask=(di2 < 11)) -&
[19._dp*2./3., 43._dp/9.*2., 0.25_dp , 0.25_dp]) < dptol))
end subroutine
subroutine test_int64_dim3_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(di3, order) - 153.4_dp*35./36.) < dptol)
call check(error, all(abs(moment(di3, order, 1) -&
reshape([20._dp / 3., 20._dp / 3., 5._dp / 3.,&
4* 20._dp / 3., 4* 20._dp / 3., 4* 5._dp / 3.,&
16* 20._dp / 3., 16* 20._dp / 3., 16* 5._dp / 3.],&
[size(di3,2), size(di3,3)])*3._dp/4.)&
< dptol))
call check(error, all(abs(moment(di3, order, 2) -&
reshape([19._dp, 43._dp / 3., 31._dp / 3. , 7.0_dp,&
4* 19.0_dp, 4* 43._dp / 3., 4* 31._dp / 3. , 4* 7.0_dp,&
16* 19.0_dp, 16* 43._dp / 3., 16* 31._dp / 3. , 16* 7.0_dp],&
[size(di3,1), size(di3,3)] )*2._dp/3.)&
< dptol))
call check(error, all(abs(moment(di3, order, 3) -&
reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
343._dp/3., 28._dp/3., 112._dp/3.,&
84._dp, 448._dp/3., 189._dp,&
700._dp/3., 847._dp/3., 336._dp],&
[size(di3,1), size(di3,2)] )*2./3.)&
< dptol))
end subroutine
subroutine test_int64_dim3_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(moment(di3, order, mask=.false.)))
call check(error, any(ieee_is_nan(moment(di3, order, 1, mask=.false.))))
call check(error, any(ieee_is_nan(moment(di3, order, 2, mask=.false.))))
call check(error, any(ieee_is_nan(moment(di3, order, 3, mask=.false.))))
end subroutine
subroutine test_int64_dim3_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(di3, order, mask=(di3 < 11)) -&
7.7370242214532876_dp ) < dptol)
call check(error, all(abs(moment(di3, order, 1, mask=(di3 < 45)) -&
reshape([5._dp, 5._dp, 1.25_dp, 20._dp, 20._dp, 5._dp,&
80._dp, 80._dp, 32._dp/3.],&
[size(di3, 2), size(di3, 3)])) < dptol ))
call check(error, all(abs(moment(di3, order, 2, mask=(di3 < 45)) -&
reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
1376._dp/9., 992._dp/9., 4._dp&
],&
[size(i3, 1), size(i3, 3)])) < dptol ))
call check(error, all(abs(moment(di3, order, 3, mask=(di3 < 45)) -&
reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
1694._dp/9., 36._dp&
], [size(di3,1), size(di3,2)] ))&
< dptol ))
end subroutine
subroutine test_csp_dim1_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(c1, order)) < sptol)
call check(error, abs(moment(c1, order, dim=1)) < sptol)
end subroutine
subroutine test_csp_dim1_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(abs(moment(c1, order, mask=.false.))))
call check(error, ieee_is_nan(abs(moment(c1, order, 1, mask=.false.))))
end subroutine
subroutine test_csp_dim1_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(c1, order, mask=(aimag(c1) == 0))) < sptol)
call check(error, abs(moment(c1, order, 1, mask=(aimag(c1) == 0))) < sptol)
end subroutine
subroutine test_csp_dim2_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(c2, order)) < sptol)
call check(error, all(abs(moment(c2, order, 1)) < sptol))
call check(error, all(abs(moment(c2, order, 2)) < sptol))
end subroutine
subroutine test_csp_dim2_mask_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, ieee_is_nan(abs(moment(c2, order, mask=.false.))))
call check(error, any(ieee_is_nan(abs(moment(c2, order, 1, mask=.false.)))))
call check(error, any(ieee_is_nan(abs(moment(c2, order, 2, mask=.false.)))))
end subroutine
subroutine test_csp_dim2_mask_array_order1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 1
call check(error, abs(moment(c2, order, mask=(aimag(c2) == 0))) < sptol)
call check(error, all(abs(moment(c2, order, 1, mask=(aimag(c2) == 0))) < sptol))
call check(error, any(ieee_is_nan( abs(moment(c2, order, 2,&
mask=(aimag(c2) == 0))))))
end subroutine
subroutine test_csp_dim1_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(c1, order) - (-6.459422410E-02,-0.556084037)) < sptol)
call check(error, abs(moment(c1, order, dim=1) -&
(-6.459422410E-02,-0.556084037)) < sptol)
end subroutine
subroutine test_csp_dim1_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(abs(moment(c1, order, mask=.false.))))
call check(error, ieee_is_nan(abs(moment(c1, order, 1, mask=.false.))))
end subroutine
subroutine test_csp_dim1_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(c1, order, mask=(aimag(c1) == 0)) -&
(8.969944715E-02,0.00000000)) < sptol)
call check(error, abs(moment(c1, order, 1, mask=(aimag(c1) == 0)) -&
(8.969944715E-02,0.00000000)) < sptol)
end subroutine
subroutine test_csp_dim2_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(c2, order) - (-0.163121477,-1.86906016)) < sptol)
call check(error, all(abs(moment(c2, order, 1) -&
[(-6.459422410E-02,-0.556084037),&
(-0.581347823,-5.00475645),&
(-0.145336956,-1.25118911)]&
) < sptol))
call check(error, all(abs(moment(c2, order, 2) -&
[(0.240498722,0.00000000),&
(-1.49895227,0.00000000),&
(1.15390968,0.00000000),&
(-0.569927275,0.00000000),&
(0.944405317,0.00000000)]&
) < sptol))
end subroutine
subroutine test_csp_dim2_mask_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, ieee_is_nan(abs(moment(c2, order, mask=.false.))))
call check(error, any(ieee_is_nan(abs(moment(c2, order, 1, mask=.false.)))))
call check(error, any(ieee_is_nan(abs(moment(c2, order, 2, mask=.false.)))))
end subroutine
subroutine test_csp_dim2_mask_array_order2(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: order = 2
call check(error, abs(moment(c2, order, mask=(aimag(c2) == 0))-&
(1.08109438,0.00000000)) < sptol)
call check(error, all(abs(moment(c2, order, 1, mask=(aimag(c2)==0)) -&
[(8.969944715E-02,0.00000000),&
(0.807295084,0.00000000),&
(0.201823771,0.00000000)]&
) < sptol))
end subroutine
end module test_moment
program tester
use, intrinsic :: iso_fortran_env, only: error_unit
use testdrive, only: run_testsuite, new_testsuite, testsuite_type
use test_moment, only: collect_moment, initialize_test_data
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("moment", collect_moment) &
]
call initialize_test_data()
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/stats/test_distribution_normal.fypp 0000664 0001750 0001750 00000034270 15135654166 026337 0 ustar alastair alastair
#:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
program test_distribution_normal
use stdlib_kinds, only : sp, dp, xdp, qp
use stdlib_error, only : check
use stdlib_random, only : random_seed
use stdlib_stats_distribution_uniform, only : uni => rvs_uniform
use stdlib_stats_distribution_normal, only : nor_rvs => rvs_normal, &
nor_pdf => pdf_normal, nor_cdf => cdf_normal
implicit none
#:for k1, t1 in REAL_KINDS_TYPES
${t1}$, parameter :: ${k1}$tol = 1000 * epsilon(1.0_${k1}$)
#:endfor
logical :: warn = .true.
integer :: put, get
put = 12345678
call random_seed(put, get)
call test_normal_random_generator
#:for k1, t1 in RC_KINDS_TYPES
call test_nor_rvs_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
call test_nor_rvs_default_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
call test_nor_pdf_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
call test_nor_cdf_${t1[0]}$${k1}$
#:endfor
contains
subroutine test_normal_random_generator
integer, parameter :: num = 10000000, array_size = 1000
integer :: i, j, freq(0:array_size)
real(dp) :: chisq, expct
print *, ""
print *, "Test normal random generator with chi-squared"
freq = 0
do i = 1, num
j = array_size * (1 + erf(nor_rvs(0.0, 1.0) / sqrt(2.0))) / 2.0
freq(j) = freq(j) + 1
end do
chisq = 0.0_dp
expct = num / array_size
do i = 0, array_size - 1
chisq = chisq + (freq(i) - expct) ** 2 / expct
end do
write(*,*) "The critical values for chi-squared with 1000 d. of f. is" &
//" 1143.92"
write(*,*) "Chi-squared for normal random generator is : ", chisq
call check((chisq < 1143.9), &
msg = "normal randomness failed chi-squared test", warn = warn)
end subroutine test_normal_random_generator
#:for k1, t1 in RC_KINDS_TYPES
subroutine test_nor_rvs_${t1[0]}$${k1}$
${t1}$ :: res(10), loc, scale
integer, parameter :: k = 5
integer :: i
integer :: seed, get
#:if t1[0] == "r"
#! for real type
${t1}$, parameter :: ans(10) = &
[2.66708039318040679432897377409972250_${k1}$, &
2.36030794936128329730706809641560540_${k1}$, &
1.27712218793084242296487218482070602_${k1}$, &
-2.39132544130814794769435138732660562_${k1}$, &
1.72566595106028652928387145948363468_${k1}$, &
-1.50621775537767632613395107910037041_${k1}$, &
2.13518835158352082714827702147886157_${k1}$, &
-0.636788253742142318358787633769679815_${k1}$, &
2.48600787778845799813609573902795091_${k1}$, &
-3.03711473837981227319460231228731573_${k1}$]
#:else
#! for complex type
${t1}$, parameter :: ans(10) = &
[(2.12531029488530509574673033057479188_${k1}$, &
1.46507698734032082432676702410390135_${k1}$), &
(1.08284164094813181722365413861552952_${k1}$, &
0.277168639672963013076412153168348595_${k1}$), &
(1.41924946329521489696290359461272601_${k1}$, &
0.498445561155580918466512230224907398_${k1}$), &
(1.72639126368764062036120776610914618_${k1}$, &
0.715802936564464420410303091557580046_${k1}$), &
(1.98950590834134349860207180427096318_${k1}$, &
0.115721315405046931701349421928171068_${k1}$), &
(-1.16929014824793620075382705181255005_${k1}$, &
0.250744737486995217246033007540972903_${k1}$), &
(1.57160542831869509683428987045772374_${k1}$, &
0.638282596371312238581197107123443857_${k1}$), &
(-1.36106107654239116833139178197598085_${k1}$, &
0.166259201494369124318950525776017457_${k1}$), &
(1.13403096805387920698038328737311531_${k1}$, &
1.04232618148691447146347854868508875_${k1}$), &
(-1.68220535920475811053620418533682823_${k1}$, &
1.63361446685040256898702182297711261_${k1}$)]
#:endif
print *, "Test normal_distribution_rvs_${t1[0]}$${k1}$"
seed = 25836914
call random_seed(seed, get)
#:if t1[0] == "r"
#! for real type
loc = 0.5_${k1}$; scale = 2.0_${k1}$
#:else
#! for complex type
loc = (0.5_${k1}$, 1.0_${k1}$); scale = (1.5_${k1}$, 0.5_${k1}$)
#:endif
do i = 1, k
res(i) = nor_rvs(loc, scale) ! 2 dummies
end do
res(6:10) = nor_rvs(loc, scale, k) ! 3 dummies
call check(all(abs(res - ans) < ${k1}$tol), &
msg="normal_distribution_rvs_${t1[0]}$${k1}$ failed", warn=warn)
end subroutine test_nor_rvs_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
subroutine test_nor_rvs_default_${t1[0]}$${k1}$
${t1}$ :: a1(10), a2(10), mold
integer :: i
integer :: seed, get
print *, "Test normal_distribution_rvs_default_${t1[0]}$${k1}$"
seed = 25836914
call random_seed(seed, get)
! explicit form with loc=0, scale=1
#:if t1[0] == "r"
a1 = nor_rvs(0.0_${k1}$, 1.0_${k1}$, 10)
#:else
a1 = nor_rvs((0.0_${k1}$, 0.0_${k1}$), (1.0_${k1}$, 1.0_${k1}$), 10)
#:endif
! reset seed to reproduce same random sequence
seed = 25836914
call random_seed(seed, get)
! default mold form: mold used only to disambiguate kind
! For real(dp), mold is optional; for other types (including complex), it's required
#:if t1[0] == "r" and k1 == "dp"
a2 = nor_rvs(10) ! mold optional for rdp only, defaults to real(dp)
#:else
#! mold required for all other types including complex and non-dp kinds
#:if t1[0] == "r"
mold = 0.0_${k1}$
#:else
mold = (0.0_${k1}$, 0.0_${k1}$)
#:endif
a2 = nor_rvs(10, mold)
#:endif
call check(all(a1 == a2), msg="normal_distribution_rvs_default_${t1[0]}$${k1}$ failed", warn=warn)
end subroutine test_nor_rvs_default_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
subroutine test_nor_pdf_${t1[0]}$${k1}$
${t1}$ :: x1, x2(3,4), loc, scale
integer, parameter :: k = 5
integer :: seed, get
real(${k1}$) :: res(3,5)
#:if t1[0] == "r"
#! for real type
real(${k1}$), parameter :: ans(15) = &
[0.215050766989949083210785218076278553_${k1}$, &
0.215050766989949083210785218076278553_${k1}$, &
0.215050766989949083210785218076278553_${k1}$, &
0.200537626692880596839299818454439236_${k1}$, &
5.66161527403268434368575024104022496E-0002_${k1}$, &
0.238986957612021514867582359518579138_${k1}$, &
0.265935969411942911029638292783132425_${k1}$, &
0.262147558654079961109031890374902943_${k1}$, &
0.249866408914952245533320687656894701_${k1}$, &
3.98721117498705317877792757313696510E-0002_${k1}$, &
0.265902369803533466897906694845094995_${k1}$, &
0.161311603170650092038944290133124635_${k1}$, &
0.249177740354276111998717092437037695_${k1}$, &
0.237427217242213206474603807278971527_${k1}$, &
0.155696086384122017518186260628090478_${k1}$]
#:else
#! for complex type
real(${k1}$), parameter :: ans(15) = &
[0.129377311291944176372137325120411497_${k1}$, &
0.129377311291944176372137325120411497_${k1}$, &
0.129377311291944176372137325120411497_${k1}$, &
4.05915662853246811934977653001971736E-0002_${k1}$, &
0.209143395418940756076861773161637924_${k1}$, &
2.98881041363874672676853084975547667E-0002_${k1}$, &
0.128679412679649127469385460133445161_${k1}$, &
0.177484732473055532384223611956177231_${k1}$, &
3.82205306942578982084957100753849738E-0002_${k1}$, &
7.09915714309796034515515428785324918E-0002_${k1}$, &
4.56126582912124629544443072483362352E-0002_${k1}$, &
6.57454133967021123696499056531595921E-0002_${k1}$, &
0.165161039915667041643464172210282279_${k1}$, &
3.86104822953520989775015755966798359E-0002_${k1}$, &
0.196922947431391188040943672442575686_${k1}$]
#:endif
print *, "Test normal_distribution_pdf_${t1[0]}$${k1}$"
seed = 741852963
call random_seed(seed, get)
#:if t1[0] == "r"
#! for real type
loc = -0.5_${k1}$; scale = 1.5_${k1}$
#:else
#! for complex type
loc = (-0.5_${k1}$, 0.5_${k1}$); scale = (0.5_${k1}$, 1.5_${k1}$)
#:endif
x1 = nor_rvs(loc, scale)
x2 = reshape(nor_rvs(loc, scale, 12), [3,4])
res(:,1) = nor_pdf(x1, loc, scale)
res(:, 2:5) = nor_pdf(x2, loc, scale)
call check(all(abs(res - reshape(ans, [3,5])) < ${k1}$tol), &
msg="normal_distribution_pdf_${t1[0]}$${k1}$ failed", warn=warn)
end subroutine test_nor_pdf_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
subroutine test_nor_cdf_${t1[0]}$${k1}$
${t1}$ :: x1, x2(3,4), loc, scale
integer :: seed, get
real(${k1}$) :: res(3,5)
#:if t1[0] == "r"
#!for real type
real(${k1}$), parameter :: ans(15) = &
[7.50826305038441048487991102776953948E-0002_${k1}$, &
7.50826305038441048487991102776953948E-0002_${k1}$, &
7.50826305038441048487991102776953948E-0002_${k1}$, &
0.143119834108717983250834016885129863_${k1}$, &
0.241425421525703182028420560765471735_${k1}$, &
0.284345878626039240974266199229875972_${k1}$, &
0.233239836366015928845367994433532757_${k1}$, &
0.341059506137219171082517155967522896_${k1}$, &
0.353156850199835111081038166086606192_${k1}$, &
6.81066766396638231790017005897813244E-0002_${k1}$, &
4.38792331441682923984716366123285346E-0002_${k1}$, &
0.763679637882860826030745070304416929_${k1}$, &
0.363722187587355040667876190724308059_${k1}$, &
0.868187114884980488672309198087692444_${k1}$, &
0.626506799809652872401992867475200722_${k1}$]
#:else
#! for complex type
real(${k1}$), parameter :: ans(15) = &
[1.07458136221563368133842063954746170E-0002_${k1}$, &
1.07458136221563368133842063954746170E-0002_${k1}$, &
1.07458136221563368133842063954746170E-0002_${k1}$, &
6.86483236063879585051085536740820057E-0002_${k1}$, &
7.95486634025192048896990048539218724E-0002_${k1}$, &
2.40523393996423661445007940057223384E-0002_${k1}$, &
3.35096768781160662250307446207445131E-0002_${k1}$, &
0.315778916661119434962814841317323376_${k1}$, &
0.446311293878359175362094845206410428_${k1}$, &
0.102010220821382542292905161748120877_${k1}$, &
7.66919007012121545175655727052974512E-0002_${k1}$, &
0.564690968410069125818268877247699603_${k1}$, &
0.708769523556518785240723539383512333_${k1}$, &
6.40553790808161720088070925562830659E-0002_${k1}$, &
5.39999153072107729358158443133850711E-0002_${k1}$]
#:endif
print *, "Test normal_distribution_cdf_${t1[0]}$${k1}$"
seed = 369147582
call random_seed(seed, get)
#:if t1[0] == "r"
#! for real type
loc = -1.0_${k1}$; scale = 2.0_${k1}$
#:else
#! for complex type
loc = (-1.0_${k1}$, 1.0_${k1}$); scale = (1.7_${k1}$, 2.4_${k1}$)
#:endif
x1 = nor_rvs(loc, scale)
x2 = reshape(nor_rvs(loc, scale, 12), [3,4])
res(:,1) = nor_cdf(x1, loc, scale)
res(:, 2:5) = nor_cdf(x2, loc, scale)
call check(all(abs(res - reshape(ans,[3,5])) < ${k1}$tol), &
msg="normal_distribution_cdf_${t1[0]}$${k1}$ failed", warn=warn)
end subroutine test_nor_cdf_${t1[0]}$${k1}$
#:endfor
end program test_distribution_normal
fortran-lang-stdlib-0ede301/test/stats/test_distribution_uniform.fypp 0000664 0001750 0001750 00000041220 15135654166 026517 0 ustar alastair alastair #:include "common.fypp"
#:set ALL_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
program test_distribution_uniform
use stdlib_error, only : check
use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
use stdlib_random, only : random_seed, dist_rand
use stdlib_stats_distribution_uniform, uni_rvs => rvs_uniform, &
uni_pdf => pdf_uniform, &
uni_cdf => cdf_uniform
implicit none
logical :: warn = .true.
#:for k1, t1 in REAL_KINDS_TYPES
${t1}$, parameter :: ${k1}$tol = 1000 * epsilon(1.0_${k1}$)
#:endfor
integer :: put
put = 135792468
call test_shuffle
call test_uni_rvs_0
#:for k1, t1 in ALL_KINDS_TYPES
call test_uni_rvs_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in ALL_KINDS_TYPES
call test_uni_pdf_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in ALL_KINDS_TYPES
call test_uni_cdf_${t1[0]}$${k1}$
#:endfor
contains
subroutine test_shuffle
integer :: n(10)
integer, parameter :: na(10) = [10, 6, 9, 2, 8, 1, 3, 5, 7, 4]
real :: x(10)
real, parameter :: xa(10) = [5.0, 10.0, 9.0, 4.0, 3.0, 8.0, 2.0, 1.0, &
7.0, 6.0]
complex :: z(10)
complex, parameter :: za(10) = [(8.0, 8.0), (7.0, 7.0), (4.0, 4.0), &
(1.0, 1.0), (5.0, 5.0), (9.0, 9.0), &
(6.0, 6.0), (3.0, 3.0), (2.0, 2.0), &
(10.0, 10.0)]
integer :: i, put, get
do i = 1, 10
n(i) = i
x(i) = real(i)
z(i) = cmplx(real(i),real(i))
end do
put = 32165498
call random_seed(put, get)
n(:) = shuffle(n)
x(:) = shuffle(x)
z(:) = shuffle(z)
call check(all(n == na), &
msg = "Integer shuffle failed test", warn=warn)
call check(all(x == xa), &
msg = "Real shuffle failed test", warn=warn)
call check(all(z == za), &
msg = "Complex shuffle failed test", warn=warn)
end subroutine test_shuffle
subroutine test_uni_rvs_0
integer, parameter :: num = 10000000
integer, parameter :: array_size = 1000
integer :: i, j, freq(0 : array_size - 1)
real(dp) :: chisq, expct
print *,""
print *, "Test uniform random generator with chi-squared"
freq = 0
do i = 1, num
j = array_size * uni_rvs( )
freq(j) = freq(j) + 1
end do
chisq = 0.0_dp
expct = num / array_size
do i = 0, array_size - 1
chisq = chisq + (freq(i) - expct) ** 2 / expct
end do
write(*,*) "The critical value for chi-squared with 1000 d. of f. is" &
//" 1143.92"
write(*,*) "Chi-squared for uniform random generator is : ", chisq
call check((chisq < 1143.9) , &
msg = "uniform randomness failed chi-squared test", warn=warn)
end subroutine test_uni_rvs_0
#:for k1, t1 in ALL_KINDS_TYPES
subroutine test_uni_rvs_${t1[0]}$${k1}$
${t1}$ :: res(15), scale, loc
integer :: i, seed, get, k
#:if k1 == "int8"
${t1}$, parameter :: ans(15) = [47, 99, 43, 37, 48, 30, 27, 100, 30, &
33, 21, 103, 55, 54, 110]
#:elif k1 == "int16"
${t1}$, parameter :: ans(15) = [25, 4, 81, 98, 49, 34, 32, 62, 115, &
112, 26, 20, 37, 100, 82]
#:elif k1 == "int32"
${t1}$, parameter :: ans(15) = [19, 52, 56, 20, 59, 44, 34, 102, 19, &
39, 60, 50, 97, 56, 67]
#:elif k1 == "int64"
${t1}$, parameter :: ans(15) = [76, 45, 43, 75, 76, 15, 25, 24, 114, &
113, 94, 29, 109, 93, 89]
#:elif t1[0] == "r"
#! for real type
${t1}$, parameter :: ans(15) = &
[0.914826628538749186958511927514337003_${k1}$, &
0.367330098664966409049981166390352882_${k1}$, &
1.77591243057709280428468900936422870_${k1}$, &
0.885921308987590139238932351872790605_${k1}$, &
0.950735656542987861428173346212133765_${k1}$, &
-0.659562573857055134407545438079978339_${k1}$, &
-0.116661718506947176265953203255776316_${k1}$, &
0.837391893893859151631886561517603695_${k1}$, &
-0.703954396598600540269075054311542772_${k1}$, &
0.382592729851141566399519433616660535_${k1}$, &
-0.132472493978185168472805344208609313_${k1}$, &
-0.878723366294216184924081858298450243_${k1}$, &
-0.901660046141515819639877804547722917_${k1}$, &
-0.164090614147737401395943379611708224_${k1}$, &
-0.333886718190384290672056977200554684_${k1}$]
#:else
#! for complex type
${t1}$, parameter :: ans(15) = &
[(0.457413314269374593479255963757168502_${k1}$, &
0.183665049332483204524990583195176441_${k1}$), &
(0.887956215288546402142344504682114348_${k1}$, &
0.442960654493795069619466175936395302_${k1}$), &
(0.475367828271493930714086673106066883_${k1}$, &
0.170218713071472432796227280960010830_${k1}$), &
(0.441669140746526411867023398372111842_${k1}$, &
0.918695946946929575815943280758801848_${k1}$), &
(0.148022801700699729865462472844228614_${k1}$, &
0.691296364925570783199759716808330268_${k1}$), &
(-6.623624698909258423640267210430465639E-0002_${k1}$, &
0.560638316852891907537959070850774879_${k1}$), &
(-0.450830023070757909819938902273861459_${k1}$, &
0.917954692926131299302028310194145888_${k1}$), &
(-0.166943359095192145336028488600277342_${k1}$, &
1.05997401970850635422038976685144007_${k1}$), &
(-0.429652190199228276035192664039641386_${k1}$, &
0.523558274341032421628217008446881664_${k1}$), &
(0.427181091476823815433760955784237012_${k1}$, &
1.34628934976074521312483511792379431_${k1}$), &
(-0.343281426018765739582860874179459643_${k1}$, &
1.15357331316264255516301773241139017_${k1}$), &
(-0.127590074749816595467422075671493076_${k1}$, &
1.06891199479835175001340985545539297_${k1}$), &
(0.262287586904722758163188700564205647_${k1}$, &
1.29508919831907332032017166056903079_${k1}$), &
(-0.192677407376582732201342196276527829_${k1}$, &
1.32794925614337933073016984053538181_${k1}$), &
(-0.264742129752461530234342035328154452_${k1}$, &
1.01282963412172621886497836385387927_${k1}$)]
#:endif
print *, "Test rvs_uniform_${t1[0]}$${k1}$"
seed = 258147369; k = 5
call random_seed(seed, get)
#:if t1[0] == "i"
#! for integer type
loc = 15_${k1}$; scale = 100_${k1}$
#:elif t1[0] == "r"
#! for real type
loc = -1.0_${k1}$; scale = 2.0_${k1}$
#:else
#! for complex type
loc = (-0.5_${k1}$,0.5_${k1}$); scale = (1.0_${k1}$, 1.0_${k1}$)
#:endif
do i = 1, 5
res(i) = uni_rvs(scale) ! 1 dummy
end do
do i = 6,10
res(i) = uni_rvs(loc, scale) ! 2 dummies
end do
res(11:15) = uni_rvs(loc, scale, k) ! 3 dummies
#:if t1[0] == "i"
#! for integer type
call check(all(res == ans), &
msg="rvs_uniform_${t1[0]}$${k1}$ failed", warn=warn)
#:else
#! for real and complex types
call check(all(abs(res - ans) < ${k1}$tol), &
msg="rvs_uniform_${t1[0]}$${k1}$ failed", warn=warn)
#:endif
end subroutine test_uni_rvs_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in ALL_KINDS_TYPES
subroutine test_uni_pdf_${t1[0]}$${k1}$
${t1}$ :: x1, x2(3,4), loc, scale
integer :: seed, get, i
#:if t1[0] == "i"
#! for integer type
real :: res(3, 5)
real, parameter :: ans(15) = [(1.96078438E-02, i=1,15)]
#:elif t1[0] == "r"
#! for real type
${t1}$ :: res(3, 5)
${t1}$, parameter :: ans(15) = [(0.5_${k1}$, i=1,15)]
#:else
#! for complex type
real(${k1}$) :: res(3, 5)
real(${k1}$), parameter :: ans(15) = [(1.0_${k1}$, i=1,15)]
#:endif
print *, "Test pdf_uniform_${t1[0]}$${k1}$"
seed = 147258639
call random_seed(seed, get)
#:if t1[0] == "i"
#! for integer type
loc = 0_${k1}$; scale = 50_${k1}$
#:elif t1[0] == "r"
#! for real type
loc = 0.0_${k1}$; scale = 2.0_${k1}$
#:else
#! for complex type
loc = (-0.5_${k1}$, 0.5_${k1}$); scale = (1.0_${k1}$, 1.0_${k1}$)
#:endif
x1 = uni_rvs(loc, scale)
x2 = reshape(uni_rvs(loc, scale, 12), [3,4])
res(:,1) = uni_pdf(x1, loc, scale)
res(:, 2:5) = uni_pdf(x2, loc, scale)
#:if t1[0] == "i"
#! for integer type
call check(all(abs(res - reshape(ans,[3,5])) < sptol), &
msg = "pdf_uniform_${t1[0]}$${k1}$ failed", warn=warn)
#:else
#! for real and complex types
call check(all(abs(res - reshape(ans,[3,5])) < ${k1}$tol), &
msg = "pdf_uniform_${t1[0]}$${k1}$ failed", warn=warn)
#:endif
end subroutine test_uni_pdf_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in ALL_KINDS_TYPES
subroutine test_uni_cdf_${t1[0]}$${k1}$
${t1}$ :: x1, x2(3,4), loc, scale
integer :: seed, get
#:if k1 == "int8"
real :: res(3,5)
real, parameter :: ans(15) = [0.435643554, 0.435643554, 0.435643554, &
0.702970326, 0.653465331, 0.485148519, &
0.386138618, 0.386138618, 0.336633652, &
0.277227730, 0.237623766, 0.524752498, &
0.732673287, 0.534653485, 0.415841579]
#:elif k1 == "int16"
real :: res(3,5)
real, parameter :: ans(15) = [0.178217828, 0.178217828, 0.178217828, &
0.465346545, 0.673267305, 0.247524753, &
0.158415839, 0.792079210, 0.742574275, &
0.574257433, 0.881188095, 0.663366318, &
0.524752498, 0.623762369, 0.178217828]
#:elif k1 == "int32"
real :: res(3,5)
real, parameter :: ans(15) = [0.732673287, 0.732673287, 0.732673287, &
0.722772300, 0.792079210, 5.94059415E-02,&
0.841584146, 0.405940592, 0.960396051, &
0.534653485, 0.782178223, 0.861386120, &
0.564356446, 0.613861382, 0.306930691]
#:elif k1 == "int64"
real :: res(3,5)
real, parameter :: ans(15) = [0.455445558, 0.455445558, 0.455445558, &
0.277227730, 0.455445558, 0.930693090, &
0.851485133, 0.623762369, 5.94059415E-02,&
0.693069279, 0.544554472, 0.207920790, &
0.306930691, 0.356435657, 0.128712878]
#:elif t1[0] == "r"
#! for real type
${t1}$ :: res(3,5)
${t1}$, parameter :: ans(15) = &
[0.170192944297557408050991512027394492_${k1}$, &
0.170192944297557408050991512027394492_${k1}$, &
0.170192944297557408050991512027394492_${k1}$, &
0.276106146274646191418611351764411665_${k1}$, &
0.754930097473875072466853453079238534_${k1}$, &
0.406620682573118008562573777453508228_${k1}$, &
0.187742819191801080247472555129206739_${k1}$, &
0.651605526090507591874256831943057477_${k1}$, &
0.934733949732104885121941606485052034_${k1}$, &
0.151271491851613287815681019310432021_${k1}$, &
0.987674522797719611766353864368284121_${k1}$, &
0.130533899463404684526679488953959662_${k1}$, &
0.106271905921876880229959283497009892_${k1}$, &
9.27578652240113182836367400341259781E-0002_${k1}$, &
0.203399426853420439709196898547816090_${k1}$]
#:else
#! for complex type
real(${k1}$) :: res(3,5)
real(${k1}$), parameter :: ans(15) = &
[4.69913179731340971083526490627998168E-0002_${k1}$, &
4.69913179731340971083526490627998168E-0002_${k1}$, &
4.69913179731340971083526490627998168E-0002_${k1}$, &
0.306970191529817593217448363707416739_${k1}$, &
0.122334258469188588238756489506609443_${k1}$, &
0.141398599060326408705075175176932616_${k1}$, &
0.128925006861443729884744412460848140_${k1}$, &
9.85755512660026594506599410104817938E-0003_${k1}$, &
8.16527497645585445208592050401597260E-0002_${k1}$, &
0.163921605454974749736935624944263178_${k1}$, &
7.81712317416218284294000447064256003E-0002_${k1}$, &
0.446415807686727375005224206895756087_${k1}$, &
5.31753272901435018841591264266743165E-0004_${k1}$, &
0.101455865191097416942685556683943046_${k1}$, &
0.155276470981788516449112374966730510_${k1}$]
#:endif
print *, "Test cdf_uniform_${t1[0]}$${k1}$"
seed = 369147258
call random_seed(seed, get)
#:if t1[0] == "i"
#! for integer type
loc = 14_${k1}$; scale = 100_${k1}$
#:elif t1[0] == "r"
#! for real type
loc = 0.0_${k1}$; scale = 2.0_${k1}$
#:else
#! for complex type
loc = (-0.5_${k1}$, -0.5_${k1}$); scale = (1.0_${k1}$, 1.0_${k1}$)
#:endif
x1 = uni_rvs(loc, scale)
x2 = reshape(uni_rvs(loc, scale, 12), [3,4])
res(:,1) = uni_cdf(x1, loc, scale)
res(:, 2:5) = uni_cdf(x2, loc, scale)
#:if t1[0] == "i"
#! for integer type
call check(all(abs(res - reshape(ans,[3,5])) < sptol), &
msg = "cdf_uniform_${t1[0]}$${k1}$ failed", warn=warn)
#:else
#! for real and complex types
call check(all(abs(res - reshape(ans,[3,5])) < ${k1}$tol), &
msg = "cdf_uniform_${t1[0]}$${k1}$ failed", warn=warn)
#:endif
end subroutine test_uni_cdf_${t1[0]}$${k1}$
#:endfor
end program test_distribution_uniform
fortran-lang-stdlib-0ede301/test/stats/test_mean_f03.fypp 0000664 0001750 0001750 00000033562 15135654166 023643 0 ustar alastair alastair #:include "common.fypp"
#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES
#:set NRANK = 4
module test_stats_meanf03
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_stats, only: mean
use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, xdp, qp
use, intrinsic :: ieee_arithmetic, only : ieee_is_nan
implicit none
private
public :: collect_stats_meanf03
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 2000 * epsilon(1._dp)
#:if WITH_XDP
real(xdp), parameter :: xdptol = 2000 * epsilon(1._xdp)
#:endif
#:if WITH_QP
real(qp), parameter :: qptol = 2000 * epsilon(1._qp)
#:endif
#:for k1,t1 in IR_KINDS_TYPES
${t1}$ , parameter :: d1_${k1}$(18) = [-10, 2, 3, 4, -6, 6, -7, 8, 9, 4, 1, -20, 9, 10, 14, 15, 40, 30]
${t1}$ :: d8_${k1}$(2, 3, 4, 2, 3, 4, 2, 3) = reshape(d1_${k1}$, [2, 3, 4, 2, 3, 4, 2, 3], [${t1}$:: 3])
#:endfor
#:for k1,t1 in CMPLX_KINDS_TYPES
${t1}$ , parameter :: d1_c${k1}$(18) = d1_${k1}$
${t1}$ :: d8_c${k1}$(2, 3, 4, 2, 3, 4, 2, 3) = reshape(d1_c${k1}$, [2, 3, 4, 2, 3, 4, 2, 3], [${t1}$:: 3])
#:endfor
contains
!> Collect all exported unit tests
subroutine collect_stats_meanf03(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("test_stats_meanf03_all_int8", test_stats_meanf03_all_int8) &
#:for k1,t1 in IR_KINDS_TYPES
,new_unittest("test_stats_meanf03_all_${k1}$", test_stats_meanf03_all_${k1}$) &
, new_unittest("test_stats_meanf03_all_optmask_${k1}$", test_stats_meanf03_all_optmask_${k1}$) &
, new_unittest("test_stats_meanf03_${k1}$", test_stats_meanf03_${k1}$) &
, new_unittest("test_stats_meanf03_optmask_${k1}$", test_stats_meanf03_optmask_${k1}$) &
, new_unittest("test_stats_meanf03_mask_all_${k1}$", test_stats_meanf03_mask_all_${k1}$) &
, new_unittest("test_stats_meanf03_mask_${k1}$", test_stats_meanf03_mask_${k1}$) &
#:endfor
#:for k1,t1 in CMPLX_KINDS_TYPES
,new_unittest("test_stats_meanf03_all_c${k1}$", test_stats_meanf03_all_c${k1}$) &
, new_unittest("test_stats_meanf03_all_optmask_c${k1}$", test_stats_meanf03_all_optmask_c${k1}$) &
, new_unittest("test_stats_meanf03_c${k1}$", test_stats_meanf03_c${k1}$) &
, new_unittest("test_stats_meanf03_optmask_c${k1}$", test_stats_meanf03_optmask_c${k1}$) &
, new_unittest("test_stats_meanf03_mask_all_c${k1}$", test_stats_meanf03_mask_all_c${k1}$) &
, new_unittest("test_stats_meanf03_mask_c${k1}$", test_stats_meanf03_mask_c${k1}$) &
#:endfor
]
end subroutine collect_stats_meanf03
#:for k1,t1 in INT_KINDS_TYPES
subroutine test_stats_meanf03_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, mean(d8_${k1}$), sum(real(d8_${k1}$, dp))/real(size(d8_${k1}$), dp)&
, 'mean(d8_${k1}$): uncorrect answer'&
, thr = dptol)
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_all_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, ieee_is_nan(mean(d8_${k1}$, .false.))&
, 'mean(d8_${k1}$, .false.): uncorrect answer')
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
#:for dim in range(1, 9)
call check(error&
, sum(abs(mean(d8_${k1}$, ${dim}$) -&
sum(real(d8_${k1}$, dp), ${dim}$)/real(size(d8_${k1}$, ${dim}$), dp))) < dptol&
, 'mean(d8_${k1}$, ${dim}$): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, ieee_is_nan(mean(d1_${k1}$, 1, .false.))&
, 'mean(d1_${k1}$, 1, .false.): uncorrect answer'&
)
if (allocated(error)) return
#:for dim in range(1, 9)
call check(error, any(ieee_is_nan(mean(d8_${k1}$, ${dim}$, .false.)))&
, 'mean(d8_${k1}$, ${dim}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_mask_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, mean(d8_${k1}$, d8_${k1}$ > 0)&
, sum(real(d8_${k1}$, dp), d8_${k1}$ > 0)/real(count(d8_${k1}$ > 0), dp)&
, 'mean(d8_${k1}$, d8_${k1}$ > 0): uncorrect answer'&
, thr = dptol)
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_mask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
#:for dim in range(1, 9)
call check(error&
, sum(abs(mean(d8_${k1}$, ${dim}$, d8_${k1}$ > 0) -&
sum(real(d8_${k1}$, dp), ${dim}$, d8_${k1}$ > 0)/real(count(d8_${k1}$ > 0, ${dim}$), dp))) < dptol&
, 'mean(d8_${k1}$, ${dim}$, d8_${k1}$ > 0): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
#:endfor
#:for k1,t1 in REAL_KINDS_TYPES
subroutine test_stats_meanf03_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, mean(d8_${k1}$), sum(d8_${k1}$)/real(size(d8_${k1}$), ${k1}$)&
, 'mean(d8_${k1}$): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_all_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, ieee_is_nan(mean(d8_${k1}$, .false.))&
, 'mean(d8_${k1}$, .false.): uncorrect answer')
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
#:for dim in range(1, 9)
call check(error&
, sum(abs(mean(d8_${k1}$, ${dim}$) -&
sum(d8_${k1}$, ${dim}$)/real(size(d8_${k1}$, ${dim}$), ${k1}$))) < ${k1}$tol&
, 'mean(d8_${k1}$, ${dim}$): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_optmask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
#:for dim in range(1, 9)
call check(error, any(ieee_is_nan(mean(d8_${k1}$, ${dim}$, .false.)))&
, 'mean(d8_${k1}$, ${dim}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_mask_all_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, mean(d8_${k1}$, d8_${k1}$ > 0)&
, sum(d8_${k1}$, d8_${k1}$ > 0)/real(count(d8_${k1}$ > 0), ${k1}$)&
, 'mean(d8_${k1}$, d8_${k1}$ > 0): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_mask_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
#:for dim in range(1, 9)
call check(error&
, sum(abs(mean(d8_${k1}$, ${dim}$, d8_${k1}$ > 0) -&
sum(d8_${k1}$, ${dim}$, d8_${k1}$ > 0)/real(count(d8_${k1}$ > 0, ${dim}$), ${k1}$))) < ${k1}$tol&
, 'mean(d8_${k1}$, ${dim}$, d8_${k1}$ > 0): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
#:endfor
#:for k1,t1 in CMPLX_KINDS_TYPES
subroutine test_stats_meanf03_all_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, mean(d8_c${k1}$), sum(d8_c${k1}$)/real(size(d8_c${k1}$), ${k1}$)&
, 'mean(d8_c${k1}$): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_all_optmask_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, ieee_is_nan(real(mean(d8_c${k1}$, .false.)))&
, 'mean(d8_c${k1}$, .false.): uncorrect answer')
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
#:for dim in range(1, 9)
call check(error&
, sum(abs(mean(d8_c${k1}$, ${dim}$) -&
sum(d8_c${k1}$, ${dim}$)/real(size(d8_c${k1}$, ${dim}$), ${k1}$))) < ${k1}$tol&
, 'mean(d8_c${k1}$, ${dim}$): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_optmask_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
#:for dim in range(1, 9)
call check(error, any(ieee_is_nan(real(mean(d8_c${k1}$, ${dim}$, .false.))))&
, 'mean(d8_c${k1}$, ${dim}$, .false.): uncorrect answer')
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_mask_all_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
call check(error, mean(d8_c${k1}$, d8_c${k1}$%re > 0)&
, sum(d8_c${k1}$, d8_c${k1}$%re > 0)/real(count(d8_c${k1}$%re > 0), ${k1}$)&
, 'mean(d8_c${k1}$, d8_c${k1}$%re > 0): uncorrect answer'&
, thr = ${k1}$tol)
if (allocated(error)) return
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
subroutine test_stats_meanf03_mask_c${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if MAXRANK > 7
#:for dim in range(1, 9)
call check(error&
, sum(abs(mean(d8_c${k1}$, ${dim}$, d8_c${k1}$%re > 0) -&
sum(d8_c${k1}$, ${dim}$, d8_c${k1}$%re > 0)/real(count(d8_c${k1}$%re > 0, ${dim}$), ${k1}$))) < ${k1}$tol&
, 'mean(d8_c${k1}$, ${dim}$, d8_c${k1}$%re > 0): uncorrect answer'&
)
if (allocated(error)) return
#:endfor
#:else
call skip_test(error, "Rank > 7 is not supported")
#:endif
end subroutine
#:endfor
end module test_stats_meanf03
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_stats_meanf03, only : collect_stats_meanf03
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("stats_meanf03", collect_stats_meanf03) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/quadrature/ 0000775 0001750 0001750 00000000000 15135654166 021322 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/quadrature/test_gauss.f90 0000664 0001750 0001750 00000060636 15135654166 024036 0 ustar alastair alastair module test_gauss
use stdlib_kinds, only: dp
use testdrive, only : new_unittest, unittest_type, error_type, check
use stdlib_quadrature , only: gauss_legendre, gauss_legendre_lobatto
implicit none
contains
!> Collect all exported unit tests
subroutine collect_gauss(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("gauss-analytic", test_gauss_analytic), &
new_unittest("gauss-5", test_gauss_5), &
new_unittest("gauss-32", test_gauss_32), &
new_unittest("gauss-64", test_gauss_64), &
new_unittest("gauss-lobatto-analytic", test_gauss_lobatto_analytic), &
new_unittest("gauss-lobatto-5", test_gauss_lobatto_5), &
new_unittest("gauss-lobatto-32", test_gauss_lobatto_32), &
new_unittest("gauss-lobatto-64", test_gauss_lobatto_64), &
new_unittest("gauss-github-issue-619", test_fix_github_issue619) &
]
end subroutine
subroutine test_gauss_analytic(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
real(dp) :: analytic, numeric
! test an analytic derivative versus an actual integration
! x**2 from -1 to 1
analytic = 2.0_dp/3.0_dp
do i=2,6
block
real(dp), dimension(i) :: x,w
call gauss_legendre(x,w)
numeric = sum(x**2 * w)
!print *, i, numeric
call check(error, abs(numeric-analytic) < 2*epsilon(analytic))
if (allocated(error)) return
end block
end do
end subroutine
subroutine test_fix_github_issue619(error)
!> See github issue https://github.com/fortran-lang/stdlib/issues/619
type(error_type), allocatable, intent(out) :: error
integer :: i
! test the values of nodes and weights
i = 5
block
real(dp), dimension(i) :: x1,w1,x2,w2
call gauss_legendre(x1,w1)
call gauss_legendre(x2,w2,interval=[-1._dp, 1._dp])
call check(error, all(abs(x1-x2) < 2*epsilon(x1(1))))
if (allocated(error)) return
call check(error, all(abs(w1-w2) < 2*epsilon(w1(1))))
end block
end subroutine
subroutine test_gauss_5(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
! test the values of nodes and weights
i = 5
block
real(dp), dimension(i) :: x,w,xref,wref
call gauss_legendre(x,w)
xref(1)=-0.90617984593866399_dp
xref(2)=-0.53846931010568309_dp
xref(3)=0.0_dp
xref(4)=0.53846931010568309_dp
xref(5)=0.90617984593866399_dp
wref(1)=0.23692688505618909_dp
wref(2)=0.47862867049936647_dp
wref(3)=0.56888888888888889_dp
wref(4)=0.47862867049936647_dp
wref(5)=0.23692688505618909_dp
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
if (allocated(error)) return
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
end block
end subroutine
subroutine test_gauss_32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
i = 32
block
real(dp), dimension(i) :: x,w,xref,wref
call gauss_legendre(x,w)
xref(1)=-0.99726386184948156_dp
xref(2)=-0.98561151154526834_dp
xref(3)=-0.96476225558750643_dp
xref(4)=-0.93490607593773969_dp
xref(5)=-0.89632115576605212_dp
xref(6)=-0.84936761373256997_dp
xref(7)=-0.79448379596794241_dp
xref(8)=-0.73218211874028968_dp
xref(9)=-0.66304426693021520_dp
xref(10)=-0.58771575724076233_dp
xref(11)=-0.50689990893222939_dp
xref(12)=-0.42135127613063535_dp
xref(13)=-0.33186860228212765_dp
xref(14)=-0.23928736225213707_dp
xref(15)=-0.14447196158279649_dp
xref(16)=-0.048307665687738316_dp
xref(17)=0.048307665687738316_dp
xref(18)=0.14447196158279649_dp
xref(19)=0.23928736225213707_dp
xref(20)=0.33186860228212765_dp
xref(21)=0.42135127613063535_dp
xref(22)=0.50689990893222939_dp
xref(23)=0.58771575724076233_dp
xref(24)=0.66304426693021520_dp
xref(25)=0.73218211874028968_dp
xref(26)=0.79448379596794241_dp
xref(27)=0.84936761373256997_dp
xref(28)=0.89632115576605212_dp
xref(29)=0.93490607593773969_dp
xref(30)=0.96476225558750643_dp
xref(31)=0.98561151154526834_dp
xref(32)=0.99726386184948156_dp
wref(1)=0.0070186100094700966_dp
wref(2)=0.016274394730905671_dp
wref(3)=0.025392065309262059_dp
wref(4)=0.034273862913021433_dp
wref(5)=0.042835898022226681_dp
wref(6)=0.050998059262376176_dp
wref(7)=0.058684093478535547_dp
wref(8)=0.065822222776361847_dp
wref(9)=0.072345794108848506_dp
wref(10)=0.078193895787070306_dp
wref(11)=0.083311924226946755_dp
wref(12)=0.087652093004403811_dp
wref(13)=0.091173878695763885_dp
wref(14)=0.093844399080804566_dp
wref(15)=0.095638720079274859_dp
wref(16)=0.096540088514727801_dp
wref(17)=0.096540088514727801_dp
wref(18)=0.095638720079274859_dp
wref(19)=0.093844399080804566_dp
wref(20)=0.091173878695763885_dp
wref(21)=0.087652093004403811_dp
wref(22)=0.083311924226946755_dp
wref(23)=0.078193895787070306_dp
wref(24)=0.072345794108848506_dp
wref(25)=0.065822222776361847_dp
wref(26)=0.058684093478535547_dp
wref(27)=0.050998059262376176_dp
wref(28)=0.042835898022226681_dp
wref(29)=0.034273862913021433_dp
wref(30)=0.025392065309262059_dp
wref(31)=0.016274394730905671_dp
wref(32)=0.0070186100094700966_dp
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
if (allocated(error)) return
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
end block
end subroutine
subroutine test_gauss_64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
i = 64
block
real(dp), dimension(i) :: x,w,xref,wref
call gauss_legendre(x,w)
xref(1)=-0.99930504173577214_dp
xref(2)=-0.99634011677195528_dp
xref(3)=-0.99101337147674432_dp
xref(4)=-0.98333625388462596_dp
xref(5)=-0.97332682778991096_dp
xref(6)=-0.96100879965205372_dp
xref(7)=-0.94641137485840282_dp
xref(8)=-0.92956917213193958_dp
xref(9)=-0.91052213707850281_dp
xref(10)=-0.88931544599511411_dp
xref(11)=-0.86599939815409282_dp
xref(12)=-0.84062929625258036_dp
xref(13)=-0.81326531512279756_dp
xref(14)=-0.78397235894334141_dp
xref(15)=-0.75281990726053190_dp
xref(16)=-0.71988185017161083_dp
xref(17)=-0.68523631305423324_dp
xref(18)=-0.64896547125465734_dp
xref(19)=-0.61115535517239325_dp
xref(20)=-0.57189564620263403_dp
xref(21)=-0.53127946401989455_dp
xref(22)=-0.48940314570705296_dp
xref(23)=-0.44636601725346409_dp
xref(24)=-0.40227015796399160_dp
xref(25)=-0.35722015833766812_dp
xref(26)=-0.31132287199021096_dp
xref(27)=-0.26468716220876742_dp
xref(28)=-0.21742364374000708_dp
xref(29)=-0.16964442042399282_dp
xref(30)=-0.12146281929612055_dp
xref(31)=-0.072993121787799039_dp
xref(32)=-0.024350292663424433_dp
xref(33)=0.024350292663424433_dp
xref(34)=0.072993121787799039_dp
xref(35)=0.12146281929612055_dp
xref(36)=0.16964442042399282_dp
xref(37)=0.21742364374000708_dp
xref(38)=0.26468716220876742_dp
xref(39)=0.31132287199021096_dp
xref(40)=0.35722015833766812_dp
xref(41)=0.40227015796399160_dp
xref(42)=0.44636601725346409_dp
xref(43)=0.48940314570705296_dp
xref(44)=0.53127946401989455_dp
xref(45)=0.57189564620263403_dp
xref(46)=0.61115535517239325_dp
xref(47)=0.64896547125465734_dp
xref(48)=0.68523631305423324_dp
xref(49)=0.71988185017161083_dp
xref(50)=0.75281990726053190_dp
xref(51)=0.78397235894334141_dp
xref(52)=0.81326531512279756_dp
xref(53)=0.84062929625258036_dp
xref(54)=0.86599939815409282_dp
xref(55)=0.88931544599511411_dp
xref(56)=0.91052213707850281_dp
xref(57)=0.92956917213193958_dp
xref(58)=0.94641137485840282_dp
xref(59)=0.96100879965205372_dp
xref(60)=0.97332682778991096_dp
xref(61)=0.98333625388462596_dp
xref(62)=0.99101337147674432_dp
xref(63)=0.99634011677195528_dp
xref(64)=0.99930504173577214_dp
wref(1)=0.0017832807216964329_dp
wref(2)=0.0041470332605624676_dp
wref(3)=0.0065044579689783629_dp
wref(4)=0.0088467598263639477_dp
wref(5)=0.011168139460131129_dp
wref(6)=0.013463047896718643_dp
wref(7)=0.015726030476024719_dp
wref(8)=0.017951715775697343_dp
wref(9)=0.020134823153530209_dp
wref(10)=0.022270173808383254_dp
wref(11)=0.024352702568710873_dp
wref(12)=0.026377469715054659_dp
wref(13)=0.028339672614259483_dp
wref(14)=0.030234657072402479_dp
wref(15)=0.032057928354851554_dp
wref(16)=0.033805161837141609_dp
wref(17)=0.035472213256882384_dp
wref(18)=0.037055128540240046_dp
wref(19)=0.038550153178615629_dp
wref(20)=0.039953741132720341_dp
wref(21)=0.041262563242623529_dp
wref(22)=0.042473515123653589_dp
wref(23)=0.043583724529323453_dp
wref(24)=0.044590558163756563_dp
wref(25)=0.045491627927418144_dp
wref(26)=0.046284796581314417_dp
wref(27)=0.046968182816210017_dp
wref(28)=0.047540165714830309_dp
wref(29)=0.047999388596458308_dp
wref(30)=0.048344762234802957_dp
wref(31)=0.048575467441503427_dp
wref(32)=0.048690957009139720_dp
wref(33)=0.048690957009139720_dp
wref(34)=0.048575467441503427_dp
wref(35)=0.048344762234802957_dp
wref(36)=0.047999388596458308_dp
wref(37)=0.047540165714830309_dp
wref(38)=0.046968182816210017_dp
wref(39)=0.046284796581314417_dp
wref(40)=0.045491627927418144_dp
wref(41)=0.044590558163756563_dp
wref(42)=0.043583724529323453_dp
wref(43)=0.042473515123653589_dp
wref(44)=0.041262563242623529_dp
wref(45)=0.039953741132720341_dp
wref(46)=0.038550153178615629_dp
wref(47)=0.037055128540240046_dp
wref(48)=0.035472213256882384_dp
wref(49)=0.033805161837141609_dp
wref(50)=0.032057928354851554_dp
wref(51)=0.030234657072402479_dp
wref(52)=0.028339672614259483_dp
wref(53)=0.026377469715054659_dp
wref(54)=0.024352702568710873_dp
wref(55)=0.022270173808383254_dp
wref(56)=0.020134823153530209_dp
wref(57)=0.017951715775697343_dp
wref(58)=0.015726030476024719_dp
wref(59)=0.013463047896718643_dp
wref(60)=0.011168139460131129_dp
wref(61)=0.0088467598263639477_dp
wref(62)=0.0065044579689783629_dp
wref(63)=0.0041470332605624676_dp
wref(64)=0.0017832807216964329_dp
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
if (allocated(error)) return
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
end block
end subroutine
subroutine test_gauss_lobatto_analytic(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
real(dp) :: analytic, numeric
! test an analytic derivative versus an actual integration
! x**2 from -1 to 1
analytic = 2.0_dp/3.0_dp
do i=4,6 ! lobatto quadrature is less accurate for low i, so omit checking at i=2,3
block
real(dp), dimension(i) :: x,w
call gauss_legendre_lobatto(x,w)
numeric = sum(x**2 * w)
!print *, i, numeric
call check(error, abs(numeric-analytic) < 2*epsilon(analytic))
if (allocated(error)) return
end block
end do
end subroutine
subroutine test_gauss_lobatto_5(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
! test the values of nodes and weights
i = 5
block
real(dp), dimension(i) :: x,w,xref,wref
call gauss_legendre_lobatto(x,w)
xref(1)=-1.0000000000000000_dp
xref(2)=-0.65465367070797714_dp
xref(3)=0.0_dp
xref(4)=0.65465367070797714_dp
xref(5)=1.0000000000000000_dp
wref(1)=0.10000000000000000_dp
wref(2)=0.54444444444444444_dp
wref(3)=0.71111111111111111_dp
wref(4)=0.54444444444444444_dp
wref(5)=0.10000000000000000_dp
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
if (allocated(error)) return
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
end block
end subroutine
subroutine test_gauss_lobatto_32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
i = 32
block
real(dp), dimension(i) :: x,w,xref,wref
call gauss_legendre_lobatto(x,w)
xref(1)=-1.0000000000000000_dp
xref(2)=-0.99260893397276136_dp
xref(3)=-0.97529469048270923_dp
xref(4)=-0.94828483841723238_dp
xref(5)=-0.91184993906373190_dp
xref(6)=-0.86635247601267552_dp
xref(7)=-0.81224473177744234_dp
xref(8)=-0.75006449393667480_dp
xref(9)=-0.68042975561555082_dp
xref(10)=-0.60403258714842113_dp
xref(11)=-0.52163226288156529_dp
xref(12)=-0.43404771720184694_dp
xref(13)=-0.34214940653888149_dp
xref(14)=-0.24685065885020530_dp
xref(15)=-0.14909859681364749_dp
xref(16)=-0.049864725046593252_dp
xref(17)=0.049864725046593252_dp
xref(18)=0.14909859681364749_dp
xref(19)=0.24685065885020530_dp
xref(20)=0.34214940653888149_dp
xref(21)=0.43404771720184694_dp
xref(22)=0.52163226288156529_dp
xref(23)=0.60403258714842113_dp
xref(24)=0.68042975561555082_dp
xref(25)=0.75006449393667480_dp
xref(26)=0.81224473177744234_dp
xref(27)=0.86635247601267552_dp
xref(28)=0.91184993906373190_dp
xref(29)=0.94828483841723238_dp
xref(30)=0.97529469048270923_dp
xref(31)=0.99260893397276136_dp
xref(32)=1.0000000000000000_dp
wref(1)=0.0020161290322580645_dp
wref(2)=0.012398106501373844_dp
wref(3)=0.022199552889291965_dp
wref(4)=0.031775135410915466_dp
wref(5)=0.041034201586062723_dp
wref(6)=0.049885271336221207_dp
wref(7)=0.058240497248055870_dp
wref(8)=0.066016877257154544_dp
wref(9)=0.073137139602679033_dp
wref(10)=0.079530525692106252_dp
wref(11)=0.085133497949668231_dp
wref(12)=0.089890372957357833_dp
wref(13)=0.093753875546813814_dp
wref(14)=0.096685608948002601_dp
wref(15)=0.098656436540761777_dp
wref(16)=0.099646771501276778_dp
wref(17)=0.099646771501276778_dp
wref(18)=0.098656436540761777_dp
wref(19)=0.096685608948002601_dp
wref(20)=0.093753875546813814_dp
wref(21)=0.089890372957357833_dp
wref(22)=0.085133497949668231_dp
wref(23)=0.079530525692106252_dp
wref(24)=0.073137139602679033_dp
wref(25)=0.066016877257154544_dp
wref(26)=0.058240497248055870_dp
wref(27)=0.049885271336221207_dp
wref(28)=0.041034201586062723_dp
wref(29)=0.031775135410915466_dp
wref(30)=0.022199552889291965_dp
wref(31)=0.012398106501373844_dp
wref(32)=0.0020161290322580645_dp
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
if (allocated(error)) return
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
end block
end subroutine
subroutine test_gauss_lobatto_64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: i
i = 64
block
real(dp), dimension(i) :: x,w,xref,wref
call gauss_legendre_lobatto(x,w)
xref(1)=-1.0000000000000000_dp
xref(2)=-0.99817987150216322_dp
xref(3)=-0.99390272670305729_dp
xref(4)=-0.98719267660274024_dp
xref(5)=-0.97806666283139607_dp
xref(6)=-0.96654711036909923_dp
xref(7)=-0.95266223578866292_dp
xref(8)=-0.93644602747563416_dp
xref(9)=-0.91793817351028163_dp
xref(10)=-0.89718396784585004_dp
xref(11)=-0.87423420065762749_dp
xref(12)=-0.84914503454299099_dp
xref(13)=-0.82197786730751705_dp
xref(14)=-0.79279918182620814_dp
xref(15)=-0.76168038340811997_dp
xref(16)=-0.72869762508883694_dp
xref(17)=-0.69393162129070484_dp
xref(18)=-0.65746745031297650_dp
xref(19)=-0.61939434613843155_dp
xref(20)=-0.57980548006771842_dp
xref(21)=-0.53879773271680044_dp
xref(22)=-0.49647145693605775_dp
xref(23)=-0.45293023223158118_dp
xref(24)=-0.40828061128985404_dp
xref(25)=-0.36263185922626182_dp
xref(26)=-0.31609568619562581_dp
xref(27)=-0.26878597401917000_dp
xref(28)=-0.22081849749695350_dp
xref(29)=-0.17231064108779297_dp
xref(30)=-0.12338111165002799_dp
xref(31)=-0.074149647946115919_dp
xref(32)=-0.024736727621958728_dp
xref(33)=0.024736727621958728_dp
xref(34)=0.074149647946115919_dp
xref(35)=0.12338111165002799_dp
xref(36)=0.17231064108779297_dp
xref(37)=0.22081849749695350_dp
xref(38)=0.26878597401917000_dp
xref(39)=0.31609568619562581_dp
xref(40)=0.36263185922626182_dp
xref(41)=0.40828061128985404_dp
xref(42)=0.45293023223158118_dp
xref(43)=0.49647145693605775_dp
xref(44)=0.53879773271680044_dp
xref(45)=0.57980548006771842_dp
xref(46)=0.61939434613843155_dp
xref(47)=0.65746745031297650_dp
xref(48)=0.69393162129070484_dp
xref(49)=0.72869762508883694_dp
xref(50)=0.76168038340811997_dp
xref(51)=0.79279918182620814_dp
xref(52)=0.82197786730751705_dp
xref(53)=0.84914503454299099_dp
xref(54)=0.87423420065762749_dp
xref(55)=0.89718396784585004_dp
xref(56)=0.91793817351028163_dp
xref(57)=0.93644602747563416_dp
xref(58)=0.95266223578866292_dp
xref(59)=0.96654711036909923_dp
xref(60)=0.97806666283139607_dp
xref(61)=0.98719267660274024_dp
xref(62)=0.99390272670305729_dp
xref(63)=0.99817987150216322_dp
xref(64)=1.0000000000000000_dp
wref(1)=0.00049603174603174603_dp
wref(2)=0.0030560082449124904_dp
wref(3)=0.0054960162038171569_dp
wref(4)=0.0079212897900466340_dp
wref(5)=0.010327002366815328_dp
wref(6)=0.012707399197454735_dp
wref(7)=0.015056683987961443_dp
wref(8)=0.017369116384542182_dp
wref(9)=0.019639040723241718_dp
wref(10)=0.021860903511518060_dp
wref(11)=0.024029268144023827_dp
wref(12)=0.026138828614338438_dp
wref(13)=0.028184422665848517_dp
wref(14)=0.030161044499089451_dp
wref(15)=0.032063857057727025_dp
wref(16)=0.033888203884125398_dp
wref(17)=0.035629620524489486_dp
wref(18)=0.037283845459801173_dp
wref(19)=0.038846830537807737_dp
wref(20)=0.040314750881560237_dp
wref(21)=0.041684014250801952_dp
wref(22)=0.042951269833601819_dp
wref(23)=0.044113416446892471_dp
wref(24)=0.045167610125947702_dp
wref(25)=0.046111271084289059_dp
wref(26)=0.046942090027028316_dp
wref(27)=0.047658033802220637_dp
wref(28)=0.048257350376414549_dp
wref(29)=0.048738573122233185_dp
wref(30)=0.049100524407501308_dp
wref(31)=0.049342318477139574_dp
wref(32)=0.049463363620776646_dp
wref(33)=0.049463363620776646_dp
wref(34)=0.049342318477139574_dp
wref(35)=0.049100524407501308_dp
wref(36)=0.048738573122233185_dp
wref(37)=0.048257350376414549_dp
wref(38)=0.047658033802220637_dp
wref(39)=0.046942090027028316_dp
wref(40)=0.046111271084289059_dp
wref(41)=0.045167610125947702_dp
wref(42)=0.044113416446892471_dp
wref(43)=0.042951269833601819_dp
wref(44)=0.041684014250801952_dp
wref(45)=0.040314750881560237_dp
wref(46)=0.038846830537807737_dp
wref(47)=0.037283845459801173_dp
wref(48)=0.035629620524489486_dp
wref(49)=0.033888203884125398_dp
wref(50)=0.032063857057727025_dp
wref(51)=0.030161044499089451_dp
wref(52)=0.028184422665848517_dp
wref(53)=0.026138828614338438_dp
wref(54)=0.024029268144023827_dp
wref(55)=0.021860903511518060_dp
wref(56)=0.019639040723241718_dp
wref(57)=0.017369116384542182_dp
wref(58)=0.015056683987961443_dp
wref(59)=0.012707399197454735_dp
wref(60)=0.010327002366815328_dp
wref(61)=0.0079212897900466340_dp
wref(62)=0.0054960162038171569_dp
wref(63)=0.0030560082449124904_dp
wref(64)=0.00049603174603174603_dp
call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
if (allocated(error)) return
call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
end block
end subroutine
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_gauss, only : collect_gauss
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("gauss", collect_gauss) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/quadrature/test_trapz.fypp 0000664 0001750 0001750 00000020447 15135654166 024430 0 ustar alastair alastair #:include "common.fypp"
module test_trapz
use stdlib_kinds, only: sp, dp, xdp, qp
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_quadrature, only: trapz, trapz_weights
implicit none
contains
!> Collect all exported unit tests
subroutine collect_trapz(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("trapz_sp", test_trapz_sp), &
new_unittest("trapz_dp", test_trapz_dp), &
new_unittest("trapz_qp", test_trapz_qp), &
new_unittest("trapz_weights_sp", test_trapz_weights_sp), &
new_unittest("trapz_weights_dp", test_trapz_weights_dp), &
new_unittest("trapz_weights_qp", test_trapz_weights_qp), &
new_unittest("trapz_zero_sp", test_trapz_zero_sp), &
new_unittest("trapz_zero_dp", test_trapz_zero_dp), &
new_unittest("trapz_zero_qp", test_trapz_zero_qp) &
]
end subroutine collect_trapz
subroutine test_trapz_sp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 17
real(sp), dimension(n) :: y
real(sp), dimension(n) :: x
real(sp) :: val
real(sp) :: ans
integer :: i
y = [(real(i-1, sp), i = 1, n)]
val = trapz(y, 1.0_sp)
ans = 128.0_sp
call check(error, abs(val - ans) < epsilon(ans))
val = trapz(y, 0.5_sp)
ans = 64.0_sp
call check(error, abs(val - ans) < epsilon(ans))
x = [((i-1)*4.0_sp/real(n-1, sp), i = 1, n)]
val = trapz(y, x)
ans = 32.0_sp
call check(error, abs(val - ans) < epsilon(ans))
x = y**2
val = trapz(y, x)
ans = 2728.0_sp
call check(error, abs(val - ans) < epsilon(ans))
end subroutine test_trapz_sp
subroutine test_trapz_dp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 17
real(dp), dimension(n) :: y
real(dp), dimension(n) :: x
real(dp) :: val
real(dp) :: ans
integer :: i
y = [(real(i-1, dp), i = 1, n)]
val = trapz(y, 1.0_dp)
ans = 128.0_dp
call check(error, abs(val - ans) < epsilon(ans))
val = trapz(y, 0.5_dp)
ans = 64.0_dp
call check(error, abs(val - ans) < epsilon(ans))
x = [((i-1)*4.0_dp/real(n-1, dp), i = 1, n)]
val = trapz(y, x)
ans = 32.0_dp
call check(error, abs(val - ans) < epsilon(ans))
x = y**2
val = trapz(y, x)
ans = 2728.0_dp
call check(error, abs(val - ans) < epsilon(ans))
end subroutine test_trapz_dp
subroutine test_trapz_qp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 17
real(qp), dimension(n) :: y
real(qp), dimension(n) :: x
real(qp) :: val
real(qp) :: ans
integer :: i
y = [(real(i-1, qp), i = 1, n)]
val = trapz(y, 1.0_qp)
ans = 128.0_qp
call check(error, abs(val - ans) < epsilon(ans))
val = trapz(y, 0.5_qp)
ans = 64.0_qp
call check(error, abs(val - ans) < epsilon(ans))
x = [((i-1)*4.0_qp/real(n-1, qp), i = 1, n)]
val = trapz(y, x)
ans = 32.0_qp
call check(error, abs(val - ans) < epsilon(ans))
x = y**2
val = trapz(y, x)
ans = 2728.0_qp
call check(error, abs(val - ans) < epsilon(ans))
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_trapz_qp
subroutine test_trapz_weights_sp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 17
real(sp), dimension(n) :: y
real(sp), dimension(n) :: x
real(sp), dimension(n) :: w
integer :: i
real(sp) :: val
real(sp) :: ans
y = [(real(i-1, sp), i = 1, n)]
x = y
w = trapz_weights(x)
val = dot_product(w, y)
ans = trapz(y, x)
call check(error, abs(val - ans) < epsilon(ans))
x = y**2
w = trapz_weights(x)
val = dot_product(w, y)
ans = trapz(y, x)
call check(error, abs(val - ans) < epsilon(ans))
end subroutine test_trapz_weights_sp
subroutine test_trapz_weights_dp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 17
real(dp), dimension(n) :: y
real(dp), dimension(n) :: x
real(dp), dimension(n) :: w
integer :: i
real(dp) :: val
real(dp) :: ans
y = [(real(i-1, dp), i = 1, n)]
x = y
w = trapz_weights(x)
val = dot_product(w, y)
ans = trapz(y, x)
call check(error, abs(val - ans) < epsilon(ans))
x = y**2
w = trapz_weights(x)
val = dot_product(w, y)
ans = trapz(y, x)
call check(error, abs(val - ans) < epsilon(ans))
end subroutine test_trapz_weights_dp
subroutine test_trapz_weights_qp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
integer, parameter :: n = 17
real(qp), dimension(n) :: y
real(qp), dimension(n) :: x
real(qp), dimension(n) :: w
integer :: i
real(qp) :: val
real(qp) :: ans
y = [(real(i-1, qp), i = 1, n)]
x = y
w = trapz_weights(x)
val = dot_product(w, y)
ans = trapz(y, x)
call check(error, abs(val - ans) < epsilon(ans))
x = y**2
w = trapz_weights(x)
val = dot_product(w, y)
ans = trapz(y, x)
call check(error, abs(val - ans) < epsilon(ans))
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_trapz_weights_qp
subroutine test_trapz_zero_sp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(sp), dimension(0) :: a
call check(error, abs(trapz(a, 1.0_sp)) < epsilon(0.0_sp))
call check(error, abs(trapz([1.0_sp], 1.0_sp)) < epsilon(0.0_sp))
call check(error, abs(trapz(a, a)) < epsilon(0.0_sp))
call check(error, abs(trapz([1.0_sp], [1.0_sp])) < epsilon(0.0_sp))
end subroutine test_trapz_zero_sp
subroutine test_trapz_zero_dp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
real(dp), dimension(0) :: a
call check(error, abs(trapz(a, 1.0_dp)) < epsilon(0.0_dp))
call check(error, abs(trapz([1.0_dp], 1.0_dp)) < epsilon(0.0_dp))
call check(error, abs(trapz(a, a)) < epsilon(0.0_dp))
call check(error, abs(trapz([1.0_dp], [1.0_dp])) < epsilon(0.0_dp))
end subroutine test_trapz_zero_dp
subroutine test_trapz_zero_qp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
real(qp), dimension(0) :: a
call check(error, abs(trapz(a, 1.0_qp)) < epsilon(0.0_qp))
call check(error, abs(trapz([1.0_qp], 1.0_qp)) < epsilon(0.0_qp))
call check(error, abs(trapz(a, a)) < epsilon(0.0_qp))
call check(error, abs(trapz([1.0_qp], [1.0_qp])) < epsilon(0.0_qp))
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_trapz_zero_qp
end module test_trapz
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_trapz, only : collect_trapz
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("trapz", collect_trapz) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/quadrature/CMakeLists.txt 0000664 0001750 0001750 00000000230 15135654166 024055 0 ustar alastair alastair set(
fppFiles
"test_simps.fypp"
"test_trapz.fypp"
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(trapz)
ADDTEST(simps)
ADDTEST(gauss)
fortran-lang-stdlib-0ede301/test/quadrature/test_simps.fypp 0000664 0001750 0001750 00000015701 15135654166 024420 0 ustar alastair alastair #:include "common.fypp"
module test_simps
use stdlib_kinds, only: sp, dp, xdp, qp
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_quadrature, only: simps, simps_weights
implicit none
#:for k1, t1 in REAL_KINDS_TYPES
${t1}$, parameter :: tol_${k1}$ = 1000 * epsilon(1.0_${k1}$)
#:endfor
contains
!> Collect all exported unit tests
subroutine collect_simps(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
#:for k1, t1 in REAL_KINDS_TYPES[0:1] # set the first test independently to initialize the table
new_unittest("simps_${k1}$", test_simps_sp) &
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[1:]
, new_unittest("simps_${k1}$", test_simps_${k1}$) &
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
, new_unittest("simps_weights_${k1}$", test_simps_weights_${k1}$) &
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
, new_unittest("simps_zero_${k1}$", test_simps_zero_${k1}$) &
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
, new_unittest("simps_even_${k1}$", test_simps_even_${k1}$) &
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
, new_unittest("simps_weights_even_${k1}$", test_simps_weights_even_${k1}$) &
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
, new_unittest("simps_six_${k1}$", test_simps_six_${k1}$) &
#:endfor
]
end subroutine collect_simps
#:for k1, t1 in REAL_KINDS_TYPES
subroutine test_simps_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 13
${t1}$ :: y(n)
${t1}$ :: x(n)
${t1}$ :: val
${t1}$ :: ans
integer :: i
y = [(real(i-1, sp)**2, i = 1, n)]
val = simps(y, 1.0_${k1}$)
ans = 576.0_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
val = simps(y, 0.5_${k1}$)
ans = 288.0_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
x = [(0.25_${k1}$*(i-1), i = 1, n)]
val = simps(y, x)
ans = 144.0_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
end subroutine test_simps_${k1}$
subroutine test_simps_weights_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 17
${t1}$ :: y(n)
${t1}$ :: x(n)
${t1}$ :: w(n)
integer :: i
${t1}$ :: val
${t1}$ :: ans
y = [(real(i-1, sp), i = 1, n)]
x = y
w = simps_weights(x)
val = sum(w*y)
ans = simps(y, x)
call check(error, val, ans, thr=tol_${k1}$)
end subroutine test_simps_weights_${k1}$
subroutine test_simps_zero_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
${t1}$, dimension(0) :: a
call check(error, abs(simps(a, 1.0_${k1}$)) < epsilon(0.0_${k1}$))
if (allocated(error)) return
call check(error, abs(simps([1.0_${k1}$], 1.0_${k1}$)) < epsilon(0.0_${k1}$))
if (allocated(error)) return
call check(error, abs(simps(a, a)) < epsilon(0.0_${k1}$))
if (allocated(error)) return
call check(error, abs(simps([1.0_${k1}$], [1.0_${k1}$])) < epsilon(0.0_${k1}$))
end subroutine test_simps_zero_${k1}$
subroutine test_simps_even_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 11
${t1}$ :: y(n)
${t1}$ :: x(n)
${t1}$ :: val
${t1}$ :: ans
integer :: i
integer :: even
y = [(3.0_${k1}$*real(i-1, sp)**2, i = 1, n)]
do even = -1, 1
val = simps(y, 1.0_${k1}$)
ans = 1000.0_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
val = simps(y, 0.5_${k1}$)
ans = 500.0_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
x = [(0.25_${k1}$*(i-1), i = 1, n)]
val = simps(y, x)
ans = 250.0_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
end do
end subroutine test_simps_even_${k1}$
subroutine test_simps_weights_even_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 16
${t1}$ :: y(n)
${t1}$ :: x(n)
${t1}$ :: w(n)
integer :: i
${t1}$ :: val
${t1}$ :: ans
integer :: even
y = [(real(i-1, sp), i = 1, n)]
x = y
do even = -1, 1
w = simps_weights(x)
val = sum(w*y)
ans = simps(y, x)
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
end do
end subroutine test_simps_weights_even_${k1}$
subroutine test_simps_six_${k1}$(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer, parameter :: n = 6
${t1}$ :: y(n)
${t1}$ :: x(n)
${t1}$ :: val
${t1}$ :: ans
integer :: i
integer :: even
y = [(3.0_${k1}$*real(i-1, sp)**2, i = 1, n)]
do even = -1, 1
val = simps(y, 1.0_${k1}$)
ans = 125.0_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
val = simps(y, 0.5_${k1}$)
ans = 62.5_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
x = [(0.25_${k1}$*(i-1), i = 1, n)]
val = simps(y, x)
ans = 31.25_${k1}$
call check(error, val, ans, thr=tol_${k1}$)
if (allocated(error)) return
end do
end subroutine test_simps_six_${k1}$
#:endfor
end module
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_simps, only : collect_simps
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("simps", collect_simps) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/optval/ 0000775 0001750 0001750 00000000000 15135654166 020452 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/optval/CMakeLists.txt 0000664 0001750 0001750 00000000511 15135654166 023207 0 ustar alastair alastair set(
fppFiles
"test_optval.fypp"
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(optval)
# prevent false positive (https://gcc.gnu.org/bugzilla/show_bug.cgi?id=95446)
if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU)
set_source_files_properties("test_optval.f90" PROPERTIES COMPILE_FLAGS "-Wno-error=pedantic")
endif()
fortran-lang-stdlib-0ede301/test/optval/test_optval.fypp 0000664 0001750 0001750 00000036554 15135654166 023733 0 ustar alastair alastair #:include "common.fypp"
module test_optval
use, intrinsic :: iso_fortran_env, only: &
sp => real32, dp => real64, qp => real128, &
int8, int16, int32, int64
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_optval, only: optval
implicit none
contains
!> Collect all exported unit tests
subroutine collect_optval(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("rsp", test_optval_rsp), &
new_unittest("rdp", test_optval_rdp), &
new_unittest("rqp", test_optval_rqp), &
new_unittest("csp", test_optval_csp), &
new_unittest("cdp", test_optval_cdp), &
new_unittest("cqp", test_optval_cqp), &
new_unittest("iint8", test_optval_iint8), &
new_unittest("iint16", test_optval_iint16), &
new_unittest("iint32", test_optval_iint32), &
new_unittest("iint64", test_optval_iint64), &
new_unittest("logical", test_optval_logical), &
new_unittest("character", test_optval_character), &
new_unittest("rsp_arr", test_optval_rsp_arr), &
new_unittest("rdp_arr", test_optval_rdp_arr), &
new_unittest("rqp_arr", test_optval_rqp_arr), &
new_unittest("csp_arr", test_optval_csp_arr), &
new_unittest("cdp_arr", test_optval_cdp_arr), &
new_unittest("cqp_arr", test_optval_cqp_arr), &
new_unittest("iint8_arr", test_optval_iint8_arr), &
new_unittest("iint16_arr", test_optval_iint16_arr), &
new_unittest("iint32_arr", test_optval_iint32_arr), &
new_unittest("iint64_arr", test_optval_iint64_arr) &
]
end subroutine collect_optval
subroutine test_optval_rsp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, foo_sp(1.0_sp) == 1.0_sp)
if (allocated(error)) return
call check(error, foo_sp() == 2.0_sp)
end subroutine test_optval_rsp
function foo_sp(x) result(z)
real(sp), intent(in), optional :: x
real(sp) :: z
z = optval(x, 2.0_sp)
endfunction foo_sp
subroutine test_optval_rdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, foo_dp(1.0_dp) == 1.0_dp)
if (allocated(error)) return
call check(error, foo_dp() == 2.0_dp)
end subroutine test_optval_rdp
function foo_dp(x) result(z)
real(dp), intent(in), optional :: x
real(dp) :: z
z = optval(x, 2.0_dp)
endfunction foo_dp
subroutine test_optval_rqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
call check(error, foo_qp(1.0_qp) == 1.0_qp)
if (allocated(error)) return
call check(error, foo_qp() == 2.0_qp)
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_optval_rqp
#:if WITH_QP
function foo_qp(x) result(z)
real(qp), intent(in), optional :: x
real(qp) :: z
z = optval(x, 2.0_qp)
endfunction foo_qp
#:endif
subroutine test_optval_csp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(sp) :: z1
z1 = cmplx(1.0_sp, 2.0_sp, kind=sp)
call check(error, foo_csp(z1) == z1)
if (allocated(error)) return
call check(error, foo_csp() == z1)
end subroutine test_optval_csp
function foo_csp(x) result(z)
complex(sp), intent(in), optional :: x
complex(sp) :: z
z = optval(x, cmplx(1.0_sp, 2.0_sp, kind=sp))
endfunction foo_csp
subroutine test_optval_cdp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(dp) :: z1
z1 = cmplx(1.0_dp, 2.0_dp,kind=dp)
call check(error, foo_cdp(z1) == z1)
if (allocated(error)) return
call check(error, foo_cdp() == z1)
end subroutine test_optval_cdp
function foo_cdp(x) result(z)
complex(dp), intent(in), optional :: x
complex(dp) :: z
z = optval(x, cmplx(1.0_dp, 2.0_dp, kind=dp))
endfunction foo_cdp
subroutine test_optval_cqp(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
complex(qp) :: z1
z1 = cmplx(1.0_qp, 2.0_qp, kind=qp)
call check(error, foo_cqp(z1) == z1)
if (allocated(error)) return
call check(error, foo_cqp() == z1)
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_optval_cqp
#:if WITH_QP
function foo_cqp(x) result(z)
complex(qp), intent(in), optional :: x
complex(qp) :: z
z = optval(x, cmplx(1.0_qp, 2.0_qp, kind=qp))
endfunction foo_cqp
#:endif
subroutine test_optval_iint8(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, foo_int8(1_int8) == 1_int8)
if (allocated(error)) return
call check(error, foo_int8() == 2_int8)
end subroutine test_optval_iint8
function foo_int8(x) result(z)
integer(int8), intent(in), optional :: x
integer(int8) :: z
z = optval(x, 2_int8)
endfunction foo_int8
subroutine test_optval_iint16(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, foo_int16(1_int16) == 1_int16)
if (allocated(error)) return
call check(error, foo_int16() == 2_int16)
end subroutine test_optval_iint16
function foo_int16(x) result(z)
integer(int16), intent(in), optional :: x
integer(int16) :: z
z = optval(x, 2_int16)
endfunction foo_int16
subroutine test_optval_iint32(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, foo_int32(1_int32) == 1_int32)
if (allocated(error)) return
call check(error, foo_int32() == 2_int32)
end subroutine test_optval_iint32
function foo_int32(x) result(z)
integer(int32), intent(in), optional :: x
integer(int32) :: z
z = optval(x, 2_int32)
endfunction foo_int32
subroutine test_optval_iint64(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, foo_int64(1_int64) == 1_int64)
if (allocated(error)) return
call check(error, foo_int64() == 2_int64)
end subroutine test_optval_iint64
function foo_int64(x) result(z)
integer(int64), intent(in), optional :: x
integer(int64) :: z
z = optval(x, 2_int64)
endfunction foo_int64
subroutine test_optval_logical(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, foo_logical(.true.))
if (allocated(error)) return
call check(error, .not.foo_logical())
end subroutine test_optval_logical
function foo_logical(x) result(z)
logical, intent(in), optional :: x
logical :: z
z = optval(x, .false.)
endfunction foo_logical
subroutine test_optval_character(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, foo_character("x") == "x")
if (allocated(error)) return
call check(error, foo_character() == "y")
end subroutine test_optval_character
function foo_character(x) result(z)
character(len=*), intent(in), optional :: x
character(len=:), allocatable :: z
z = optval(x, "y")
endfunction foo_character
subroutine test_optval_rsp_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, all(foo_sp_arr([1.0_sp, -1.0_sp]) == [1.0_sp, -1.0_sp]))
if (allocated(error)) return
call check(error, all(foo_sp_arr() == [2.0_sp, -2.0_sp]))
end subroutine test_optval_rsp_arr
function foo_sp_arr(x) result(z)
real(sp), dimension(2), intent(in), optional :: x
real(sp), dimension(2) :: z
z = optval(x, [2.0_sp, -2.0_sp])
end function foo_sp_arr
subroutine test_optval_rdp_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, all(foo_dp_arr([1.0_dp, -1.0_dp]) == [1.0_dp, -1.0_dp]))
if (allocated(error)) return
call check(error, all(foo_dp_arr() == [2.0_dp, -2.0_dp]))
end subroutine test_optval_rdp_arr
function foo_dp_arr(x) result(z)
real(dp), dimension(2), intent(in), optional :: x
real(dp), dimension(2) :: z
z = optval(x, [2.0_dp, -2.0_dp])
end function foo_dp_arr
subroutine test_optval_rqp_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
call check(error, all(foo_qp_arr([1.0_qp, -1.0_qp]) == [1.0_qp, -1.0_qp]))
if (allocated(error)) return
call check(error, all(foo_qp_arr() == [2.0_qp, -2.0_qp]))
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_optval_rqp_arr
#:if WITH_QP
function foo_qp_arr(x) result(z)
real(qp), dimension(2), intent(in), optional :: x
real(qp), dimension(2) :: z
z = optval(x, [2.0_qp, -2.0_qp])
end function foo_qp_arr
#:endif
subroutine test_optval_csp_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(sp), dimension(2) :: z1, z2
z1 = cmplx(1.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp]
z2 = cmplx(2.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp]
call check(error, all(foo_csp_arr(z1) == z1))
if (allocated(error)) return
call check(error, all(foo_csp_arr() == z2))
end subroutine test_optval_csp_arr
function foo_csp_arr(x) result(z)
complex(sp), dimension(2), intent(in), optional :: x
complex(sp), dimension(2) :: z
z = optval(x, cmplx(2.0_sp, 2.0_sp, kind=sp)*[1.0_sp, -1.0_sp])
end function foo_csp_arr
subroutine test_optval_cdp_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
complex(dp), dimension(2) :: z1, z2
z1 = cmplx(1.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp]
z2 = cmplx(2.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp]
call check(error, all(foo_cdp_arr(z1) == z1))
if (allocated(error)) return
call check(error, all(foo_cdp_arr() == z2))
end subroutine test_optval_cdp_arr
function foo_cdp_arr(x) result(z)
complex(dp), dimension(2), intent(in), optional :: x
complex(dp), dimension(2) :: z
z = optval(x, cmplx(2.0_dp, 2.0_dp, kind=dp)*[1.0_dp, -1.0_dp])
end function foo_cdp_arr
subroutine test_optval_cqp_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
#:if WITH_QP
complex(qp), dimension(2) :: z1, z2
z1 = cmplx(1.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp]
z2 = cmplx(2.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp]
call check(error, all(foo_cqp_arr(z1) == z1))
if (allocated(error)) return
call check(error, all(foo_cqp_arr() == z2))
#:else
call skip_test(error, "Quadruple precision is not enabled")
#:endif
end subroutine test_optval_cqp_arr
#:if WITH_QP
function foo_cqp_arr(x) result(z)
complex(qp), dimension(2), intent(in), optional :: x
complex(qp), dimension(2) :: z
z = optval(x, cmplx(2.0_qp, 2.0_qp, kind=qp)*[1.0_qp, -1.0_qp])
end function foo_cqp_arr
#:endif
subroutine test_optval_iint8_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, all(foo_int8_arr([1_int8, -1_int8]) == [1_int8, -1_int8]))
if (allocated(error)) return
call check(error, all(foo_int8_arr() == [2_int8, -2_int8]))
end subroutine test_optval_iint8_arr
function foo_int8_arr(x) result(z)
integer(int8), dimension(2), intent(in), optional :: x
integer(int8), dimension(2) :: z
z = optval(x, [2_int8, -2_int8])
end function foo_int8_arr
subroutine test_optval_iint16_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, all(foo_int16_arr([1_int16, -1_int16]) == [1_int16, -1_int16]))
if (allocated(error)) return
call check(error, all(foo_int16_arr() == [2_int16, -2_int16]))
end subroutine test_optval_iint16_arr
function foo_int16_arr(x) result(z)
integer(int16), dimension(2), intent(in), optional :: x
integer(int16), dimension(2) :: z
z = optval(x, [2_int16, -2_int16])
end function foo_int16_arr
subroutine test_optval_iint32_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, all(foo_int32_arr([1_int32, -1_int32]) == [1_int32, -1_int32]))
if (allocated(error)) return
call check(error, all(foo_int32_arr() == [2_int32, -2_int32]))
end subroutine test_optval_iint32_arr
function foo_int32_arr(x) result(z)
integer(int32), dimension(2), intent(in), optional :: x
integer(int32), dimension(2) :: z
z = optval(x, [2_int32, -2_int32])
end function foo_int32_arr
subroutine test_optval_iint64_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, all(foo_int64_arr([1_int64, -1_int64]) == [1_int64, -1_int64]))
if (allocated(error)) return
call check(error, all(foo_int64_arr() == [2_int64, -2_int64]))
end subroutine test_optval_iint64_arr
function foo_int64_arr(x) result(z)
integer(int64), dimension(2), intent(in), optional :: x
integer(int64), dimension(2) :: z
z = optval(x, [2_int64, -2_int64])
end function foo_int64_arr
subroutine test_optval_logical_arr(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
call check(error, all(foo_logical_arr()))
if (allocated(error)) return
call check(error, all(.not.foo_logical_arr()))
end subroutine test_optval_logical_arr
function foo_logical_arr(x) result(z)
logical, dimension(2), intent(in), optional :: x
logical, dimension(2) :: z
z = optval(x, [.false., .false.])
end function foo_logical_arr
end module test_optval
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_optval, only : collect_optval
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("optval", collect_optval) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/system/ 0000775 0001750 0001750 00000000000 15135654166 020471 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/system/test_path.f90 0000664 0001750 0001750 00000013103 15135654166 023002 0 ustar alastair alastair module test_path
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_system, only: join_path, operator(/), split_path, OS_TYPE, OS_WINDOWS
implicit none
contains
!> Collect all exported unit tests
subroutine collect_suite(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('test_join_path', test_join_path), &
new_unittest('test_join_path_operator', test_join_path_op), &
new_unittest('test_split_path', test_split_path) &
]
end subroutine collect_suite
subroutine checkpath(error, funcname, expected, got)
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: funcname
character(len=*), intent(in) :: expected
character(len=:), allocatable :: got
character(len=:), allocatable :: message
message = "'"//funcname//"'"//" error: Expected '"// expected // "' but got '" // got // "'"
call check(error, expected == got, message)
end subroutine checkpath
subroutine test_join_path(error)
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: path
character(len=20) :: paths(5)
if (OS_TYPE() == OS_WINDOWS) then
path = join_path('C:\Users', 'Alice')
call checkpath(error, 'join_path', 'C:\Users\Alice', path)
if (allocated(error)) return
paths = [character(20) :: 'C:','Users','Bob','Pictures','2025']
path = join_path(paths)
call checkpath(error, 'join_path', 'C:\Users\Bob\Pictures\2025', path)
if (allocated(error)) return
path = join_path('"C:\Users\John Doe"', 'Pictures\2025') ! path with spaces
call checkpath(error, 'join_path', '"C:\Users\John Doe"\Pictures\2025', path)
if (allocated(error)) return
else
path = join_path('/home', 'Alice')
call checkpath(error, 'join_path', '/home/Alice', path)
if (allocated(error)) return
paths = [character(20) :: '','home','Bob','Pictures','2025']
path = join_path(paths)
call checkpath(error, 'join_path', '/home/Bob/Pictures/2025', path)
if (allocated(error)) return
end if
end subroutine test_join_path
!> Test the operator
subroutine test_join_path_op(error)
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: path
if (OS_TYPE() == OS_WINDOWS) then
path = 'C:'/'Users'/'Alice'/'Desktop'
call checkpath(error, 'join_path operator', 'C:\Users\Alice\Desktop', path)
if (allocated(error)) return
else
path = ''/'home'/'Alice'/'.config'
call checkpath(error, 'join_path operator', '/home/Alice/.config', path)
if (allocated(error)) return
end if
end subroutine test_join_path_op
subroutine test_split_path(error)
type(error_type), allocatable, intent(out) :: error
character(len=:), allocatable :: head, tail
call split_path('', head, tail)
call checkpath(error, 'split_path-head', '.', head)
if (allocated(error)) return
call checkpath(error, 'split_path-tail', '', tail)
if (allocated(error)) return
if (OS_TYPE() == OS_WINDOWS) then
call split_path('\\\\', head, tail)
call checkpath(error, 'split_path-head', '\', head)
if (allocated(error)) return
call checkpath(error, 'split_path-tail', '', tail)
if (allocated(error)) return
call split_path('C:\', head, tail)
call checkpath(error, 'split_path-head', 'C:\', head)
if (allocated(error)) return
call checkpath(error, 'split_path-tail', '', tail)
if (allocated(error)) return
call split_path('C:\Users\Alice\\\\\', head, tail)
call checkpath(error, 'split_path-head', 'C:\Users', head)
if (allocated(error)) return
call checkpath(error, 'split_path-tail', 'Alice', tail)
if (allocated(error)) return
else
call split_path('/////', head, tail)
call checkpath(error, 'split_path-head', '/', head)
if (allocated(error)) return
call checkpath(error, 'split_path-tail', '', tail)
if (allocated(error)) return
call split_path('/home/Alice/foo/bar.f90///', head, tail)
call checkpath(error, 'split_path-head', '/home/Alice/foo', head)
if (allocated(error)) return
call checkpath(error, 'split_path-tail', 'bar.f90', tail)
if (allocated(error)) return
end if
end subroutine test_split_path
end module test_path
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_path, only : collect_suite
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("path", collect_suite) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/system/CMakeLists.txt 0000664 0001750 0001750 00000000121 15135654166 023223 0 ustar alastair alastair ADDTEST(filesystem)
ADDTEST(os)
ADDTEST(sleep)
ADDTEST(subprocess)
ADDTEST(path)
fortran-lang-stdlib-0ede301/test/system/test_os.f90 0000664 0001750 0001750 00000006050 15135654166 022472 0 ustar alastair alastair module test_os
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_system, only: get_runtime_os, OS_WINDOWS, OS_UNKNOWN, OS_TYPE, is_windows, null_device
implicit none
contains
!> Collect all exported unit tests
subroutine collect_suite(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('test_get_runtime_os', test_get_runtime_os), &
new_unittest('test_is_windows', test_is_windows), &
new_unittest('test_null_device', test_null_device) &
]
end subroutine collect_suite
subroutine test_get_runtime_os(error)
type(error_type), allocatable, intent(out) :: error
integer :: os
!> Get current OS
os = get_runtime_os()
call check(error, os /= OS_UNKNOWN, "running on an unknown/unsupported OS")
end subroutine test_get_runtime_os
!> If running on Windows (_WIN32 macro is defined), test that the appropriate OS flag is returned
subroutine test_is_windows(error)
type(error_type), allocatable, intent(out) :: error
integer :: os_cached, os_runtime
call check(error, OS_TYPE()==OS_WINDOWS .eqv. is_windows(), &
"Cached OS type does not match _WIN32 macro presence")
end subroutine test_is_windows
!> Test that the null_device is valid by writing something to it
subroutine test_null_device(error)
type(error_type), allocatable, intent(out) :: error
integer :: unit, ios
character(len=512) :: iomsg
! Try opening the null device for writing
open(newunit=unit, file=null_device(), status='old', action='write', iostat=ios, iomsg=iomsg)
call check(error, ios==0, 'Cannot open null_device unit: '//trim(iomsg))
if (allocated(error)) return
write(unit, *, iostat=ios, iomsg=iomsg) 'Hello, World!'
call check(error, ios==0, 'Cannot write to null_device unit: '//trim(iomsg))
if (allocated(error)) return
close(unit, iostat=ios, iomsg=iomsg)
call check(error, ios==0, 'Cannot close null_device unit: '//trim(iomsg))
if (allocated(error)) return
end subroutine test_null_device
end module test_os
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_os, only : collect_suite
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("os", collect_suite) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/system/test_sleep.f90 0000664 0001750 0001750 00000003314 15135654166 023161 0 ustar alastair alastair module test_sleep
use, intrinsic :: iso_fortran_env, only : int64, real64
use stdlib_system, only : sleep
use testdrive, only: new_unittest, unittest_type, error_type, check
implicit none
private
public :: collect_sleep
integer, parameter :: millisec = 100
contains
!> Collect all exported unit tests
subroutine collect_sleep(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('sleep', test_sleep_) &
]
end subroutine collect_sleep
subroutine test_sleep_(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(int64) :: tic, toc, trate
real(real64) :: t_ms
call system_clock(count_rate=trate)
call system_clock(count=tic)
call sleep(millisec)
call system_clock(count=toc)
t_ms = (toc - tic) * 1000._real64 / trate
call check(error, t_ms, real(millisec, real64), thr=1.5_real64, rel=.true.)
end subroutine test_sleep_
end module test_sleep
program tester
use, intrinsic :: iso_fortran_env, only: error_unit
use testdrive, only: run_testsuite, new_testsuite, testsuite_type
use test_sleep, only: collect_sleep
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite('sleep', collect_sleep) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program tester
fortran-lang-stdlib-0ede301/test/system/test_filesystem.f90 0000664 0001750 0001750 00000055305 15135654166 024244 0 ustar alastair alastair module test_filesystem
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_system, only: is_directory, delete_file, FS_ERROR, FS_ERROR_CODE, &
make_directory, remove_directory, make_directory_all, is_windows, OS_TYPE, &
OS_WINDOWS, get_cwd, set_cwd, operator(/), exists, fs_type_unknown, &
fs_type_regular_file, fs_type_directory, fs_type_symlink, is_file
use stdlib_error, only: state_type, STDLIB_FS_ERROR
use stdlib_strings, only: to_string
implicit none
contains
!> Collect all exported unit tests
subroutine collect_suite(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("fs_error", test_fs_error), &
new_unittest("fs_exists_not_exists", test_exists_not_exists), &
new_unittest("fs_exists_reg_file", test_exists_reg_file), &
new_unittest("fs_exists_dir", test_exists_dir), &
new_unittest("fs_exists_symlink", test_exists_symlink), &
new_unittest("fs_is_file", test_is_file), &
new_unittest("fs_is_directory_dir", test_is_directory_dir), &
new_unittest("fs_is_directory_file", test_is_directory_file), &
new_unittest("fs_delete_non_existent", test_delete_file_non_existent), &
new_unittest("fs_delete_existing_file", test_delete_file_existing), &
new_unittest("fs_delete_file_being_dir", test_delete_directory), &
new_unittest("fs_make_dir", test_make_directory), &
new_unittest("fs_make_dir_existing_dir", test_make_directory_existing), &
new_unittest("fs_make_dir_all", test_make_directory_all), &
new_unittest("fs_remove_dir", test_remove_directory), &
new_unittest("fs_remove_dir_non_existent", test_remove_directory_nonexistent), &
new_unittest("fs_cwd", test_cwd) &
]
end subroutine collect_suite
subroutine test_fs_error(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: s1, s2
character(:), allocatable :: msg
msg = "code - 10, Cannot create File temp.txt - File already exists"
s1 = FS_ERROR_CODE(10, "Cannot create File temp.txt -", "File already exists")
call check(error, s1%state == STDLIB_FS_ERROR .and. s1%message == msg, &
"FS_ERROR_CODE: Could not construct the state with code correctly")
if (allocated(error)) return
msg = "Cannot create File temp.txt - File already exists"
s2 = FS_ERROR("Cannot create File temp.txt -", "File already exists")
call check(error, s2%state == STDLIB_FS_ERROR .and. s2%message == msg, &
"FS_ERROR: Could not construct state without code correctly")
if (allocated(error)) return
end subroutine test_fs_error
subroutine test_exists_not_exists(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(*), parameter :: path = "rand_name"
integer :: t
t = exists(path, err)
call check(error, err%error(), "False positive for a non-existent path!")
end subroutine test_exists_not_exists
subroutine test_exists_reg_file(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(len=256) :: filename
integer :: ios, iunit, t
character(len=512) :: msg
filename = "test_file.txt"
! Create a file
open(newunit=iunit, file=filename, status="replace", iostat=ios, iomsg=msg)
call check(error, ios == 0, "Cannot init test_exists_reg_file: " // trim(msg))
if (allocated(error)) return
t = exists(filename, err)
call check(error, err%ok(), "exists failed for reg file: " // err%print())
if (allocated(error)) then
! Clean up: remove the file
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, error%message// " and cannot delete test file: " // trim(msg))
return
end if
call check(error, t == fs_type_regular_file, "exists incorrectly identifies type of &
reg files!: type=" // to_string(t))
if (allocated(error)) then
! Clean up: remove the file
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, error%message// " and cannot delete test file: " // trim(msg))
return
end if
! Clean up: remove the file
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, "Cannot delete test file: " // trim(msg))
if (allocated(error)) return
end subroutine test_exists_reg_file
subroutine test_is_file(error)
type(error_type), allocatable, intent(out) :: error
character(len=256) :: filename
integer :: ios, iunit
character(len=512) :: msg
logical :: is_reg_file
filename = "test_file.txt"
! Create a file
open(newunit=iunit, file=filename, status="replace", iostat=ios, iomsg=msg)
call check(error, ios == 0, "Cannot init test_is_file: " // trim(msg))
if (allocated(error)) return
is_reg_file = is_file(filename)
call check(error, is_reg_file, "is_file could not identify a file")
if (allocated(error)) then
! Clean up: remove the file
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, error%message// " and cannot delete test file: " // trim(msg))
return
end if
! Clean up: remove the file
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, "Cannot delete test file: " // trim(msg))
if (allocated(error)) return
end subroutine test_is_file
subroutine test_exists_dir(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(len=256) :: dirname
integer :: ios, iocmd, t
character(len=512) :: msg
dirname = "temp_dir"
! Create a directory
call execute_command_line("mkdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, "Cannot int test_exists_dir: " // trim(msg))
if (allocated(error)) return
t = exists(dirname, err)
call check(error, err%ok(), "exists failed for directory: " // err%print())
if (allocated(error)) then
! Clean up: remove the directory
call execute_command_line("rmdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, error%message // " and &
& cannot cleanup test_exists_dir: " // trim(msg))
return
end if
call check(error, t == fs_type_directory, "exists incorrectly identifies type of &
directories!: type=" // to_string(t))
if (allocated(error)) then
! Clean up: remove the directory
call execute_command_line("rmdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, error%message // " and &
& cannot cleanup test_exists_dir: " // trim(msg))
return
end if
! Clean up: remove the directory
call execute_command_line("rmdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, "Cannot cleanup test_exists_dir: " // trim(msg))
end subroutine test_exists_dir
subroutine test_exists_symlink(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(len=128) :: target_name, link_name
integer :: ios, iunit, iocmd, t
character(len=512) :: msg, cmd
target_name = "test_file.txt"
link_name = "symlink.txt"
! Create a file
open(newunit=iunit, file=target_name, status="replace", iostat=ios, iomsg=msg)
call check(error, ios == 0, "Cannot init test_exists_symlink: " // trim(msg))
if (allocated(error)) return
if (is_windows()) then
cmd = 'mklink '//link_name//' '//target_name
call execute_command_line(cmd, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
else
cmd = 'ln -s '//target_name//' '//link_name
call execute_command_line(cmd, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
end if
call check(error, ios == 0 .and. iocmd == 0, "Cannot create symlink!: " // trim(msg))
if (allocated(error)) then
! Clean up: remove the target
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, error%message // " and cannot delete target: " // trim(msg))
return
end if
t = exists(link_name, err)
call check(error, err%ok(), "exists failed for symlink: " // err%print())
if (allocated(error)) then
! Clean up: remove the link
call execute_command_line("rm " // link_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, error%message // " and &
& cannot delete link: " // trim(msg))
! Clean up: remove the target
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, error%message // " and cannot delete target: " // trim(msg))
return
end if
call check(error, t == fs_type_symlink, "exists incorrectly identifies type of &
symlinks!: type=" // to_string(t))
if (allocated(error)) then
! Clean up: remove the link
call execute_command_line("rm " // link_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, error%message // " and &
& cannot delete link: " // trim(msg))
! Clean up: remove the target
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, error%message // " and cannot delete target: " // trim(msg))
return
end if
! Clean up: remove the link
call execute_command_line("rm " // link_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, "Cannot delete link: " // trim(msg))
if (allocated(error)) then
! Clean up: remove the target
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, error%message // " and cannot delete target: " // trim(msg))
end if
! Clean up: remove the target
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, "Cannot delete target: " // trim(msg))
end subroutine test_exists_symlink
! Test `is_directory` for a directory
subroutine test_is_directory_dir(error)
type(error_type), allocatable, intent(out) :: error
character(len=256) :: dirname
integer :: ios, iocmd
character(len=512) :: msg
dirname = "this_test_dir_tmp"
! Create a directory
call execute_command_line("mkdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, "Cannot create test directory: " // trim(msg))
if (allocated(error)) return
! Verify `is_directory` identifies it as a directory
call check(error, is_directory(dirname), "is_directory did not recognize a valid directory")
if (allocated(error)) return
! Clean up: remove the directory
call execute_command_line("rmdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios == 0 .and. iocmd == 0, "Cannot remove test directory: " // trim(msg))
end subroutine test_is_directory_dir
! Test `is_directory` for a regular file
subroutine test_is_directory_file(error)
type(error_type), allocatable, intent(out) :: error
character(len=256) :: filename
logical :: result
integer :: ios, iunit
character(len=512) :: msg
filename = "test_file.txt"
! Create a file
open(newunit=iunit, file=filename, status="replace", iostat=ios, iomsg=msg)
call check(error, ios == 0, "Cannot create test file: " // trim(msg))
if (allocated(error)) return
! Verify `is_directory` identifies it as not a directory
result = is_directory(filename)
call check(error, .not. result, "is_directory falsely recognized a regular file as a directory")
if (allocated(error)) return
! Clean up: remove the file
close(iunit,status='delete',iostat=ios,iomsg=msg)
call check(error, ios == 0, "Cannot delete test file: " // trim(msg))
if (allocated(error)) return
end subroutine test_is_directory_file
subroutine test_delete_file_non_existent(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(state_type) :: state
! Attempt to delete a file that doesn't exist
call delete_file('non_existent_file.txt', state)
call check(error, state%ok(), 'Error should not be triggered for non-existent file')
if (allocated(error)) return
end subroutine test_delete_file_non_existent
subroutine test_delete_file_existing(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=256) :: filename
type(state_type) :: state
integer :: ios,iunit
logical :: is_present
character(len=512) :: msg
filename = 'existing_file.txt'
! Create a file to be deleted
open(newunit=iunit, file=filename, status='replace', iostat=ios, iomsg=msg)
call check(error, ios==0, 'Failed to create test file')
if (allocated(error)) return
close(iunit)
! Attempt to delete the existing file
call delete_file(filename, state)
! Check deletion successful
call check(error, state%ok(), 'delete_file returned '//state%print())
if (allocated(error)) return
! Check if the file was successfully deleted (should no longer exist)
inquire(file=filename, exist=is_present)
call check(error, .not.is_present, 'File still present after delete')
if (allocated(error)) return
end subroutine test_delete_file_existing
subroutine test_delete_directory(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
character(len=256) :: filename
type(state_type) :: state
integer :: ios,iocmd
character(len=512) :: msg
filename = 'test_directory'
! The directory is not nested: it should be cross-platform to just call `mkdir`
call execute_command_line('mkdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios==0 .and. iocmd==0, 'Cannot init delete_directory test: '//trim(msg))
if (allocated(error)) return
! Attempt to delete a directory (which should fail)
call delete_file(filename, state)
! Check that an error was raised since the target is a directory
call check(error, state%error(), 'Error was not triggered trying to delete directory')
if (allocated(error)) return
! Clean up: remove the empty directory
call execute_command_line('rmdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup delete_directory test: '//trim(msg))
if (allocated(error)) return
end subroutine test_delete_directory
subroutine test_make_directory(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(len=256) :: dir_name
integer :: ios,iocmd
character(len=512) :: msg
dir_name = "test_directory"
call make_directory(dir_name, err=err)
call check(error, err%ok(), 'Could not make directory: '//err%print())
if (allocated(error)) return
! clean up: remove the empty directory
call execute_command_line('rmdir ' // dir_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup make_directory test: '//trim(msg))
end subroutine test_make_directory
subroutine test_make_directory_existing(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(len=256) :: dir_name
integer :: ios,iocmd
character(len=512) :: msg
dir_name = "test_directory"
call execute_command_line('mkdir ' // dir_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios==0 .and. iocmd==0, 'Cannot init make_directory_existing test: '//trim(msg))
if (allocated(error)) return
call make_directory(dir_name, err=err)
call check(error, err%error(), 'Made an already existing directory somehow')
! clean up: remove the empty directory
call execute_command_line('rmdir ' // dir_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
if (allocated(error)) then
! if previous error is allocated as well
call check(error, ios==0 .and. iocmd==0, error%message // ' and cannot cleanup make_directory test: '//trim(msg))
return
end if
call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup make_directory test: '//trim(msg))
end subroutine test_make_directory_existing
subroutine test_make_directory_all(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(len=256) :: dir_name
integer :: ios,iocmd
character(len=512) :: msg
if (OS_TYPE() == OS_WINDOWS) then
dir_name = "d1\d2\d3\d4\"
else
dir_name = "d1/d2/d3/d4/"
end if
call make_directory_all(dir_name, err=err)
call check(error, err%ok(), 'Could not make all directories: '//err%print())
if (allocated(error)) return
! clean up: remove the empty directory
if (is_windows()) then
call execute_command_line('rmdir /s /q d1', exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
else
call execute_command_line('rm -rf d1', exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
end if
call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup make_directory_all test: '//trim(msg))
end subroutine test_make_directory_all
subroutine test_remove_directory(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(len=256) :: dir_name
integer :: ios,iocmd
character(len=512) :: msg
dir_name = "test_directory"
call execute_command_line('mkdir ' // dir_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios==0 .and. iocmd==0, 'Cannot init remove_directory test: '//trim(msg))
if (allocated(error)) return
call remove_directory(dir_name, err)
call check(error, err%ok(), 'Could not remove directory: '//err%print())
if (allocated(error)) then
! clean up: remove the empty directory
call execute_command_line('rmdir ' // dir_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios==0 .and. iocmd==0, error%message // ' and cannot cleanup make_directory test: '//trim(msg))
end if
end subroutine test_remove_directory
subroutine test_remove_directory_nonexistent(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
call remove_directory("random_name", err)
call check(error, err%error(), 'Somehow removed a non-existent directory')
if (allocated(error)) return
end subroutine test_remove_directory_nonexistent
subroutine test_cwd(error)
type(error_type), allocatable, intent(out) :: error
type(state_type) :: err
character(len=256) :: dir_name
integer :: ios,iocmd
character(len=512) :: msg
character(:), allocatable :: pwd1, pwd2, abs_dir_name
! get the initial cwd
call get_cwd(pwd1, err)
call check(error, err%ok(), 'Could not get current working directory: '//err%print())
if (allocated(error)) return
! create a temporary directory for use by `set_cwd`
dir_name = "test_directory"
call execute_command_line('mkdir ' // dir_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios==0 .and. iocmd==0, 'Cannot init cwd test: '//trim(msg))
if (allocated(error)) return
abs_dir_name = pwd1 / dir_name
call set_cwd(abs_dir_name, err)
call check(error, err%ok(), 'Could not set current working directory: '//err%print())
if (allocated(error)) return
! get the new cwd -> should be same as (pwd1 / dir_name)
call get_cwd(pwd2, err)
call check(error, err%ok(), 'Could not get current working directory: '//err%print())
if (allocated(error)) return
call check(error, pwd2 == abs_dir_name, 'Working directory is wrong, &
& expected: '//abs_dir_name//" got: "//pwd2)
if (allocated(error)) return
! cleanup: set the cwd back to the initial value
call set_cwd(pwd1, err)
call check(error, err%ok(), 'Could not clean up cwd test, could not set the cwd back: '//err%print())
if (allocated(error)) then
! our cwd now is `./test_directory`
! there is no way of removing the empty test directory
return
end if
! cleanup: remove the empty directory
call execute_command_line('rmdir ' // dir_name, exitstat=ios, cmdstat=iocmd, cmdmsg=msg)
call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup cwd test, cannot remove empty dir: '//trim(msg))
if (allocated(error)) return
end subroutine test_cwd
end module test_filesystem
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_filesystem, only : collect_suite
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("filesystem", collect_suite) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/system/test_subprocess.f90 0000664 0001750 0001750 00000015235 15135654166 024246 0 ustar alastair alastair module test_subprocess
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_system, only: process_type, run, runasync, is_running, wait, update, elapsed, is_windows, kill
implicit none
contains
!> Collect all exported unit tests
subroutine collect_suite(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('test_run_synchronous', test_run_synchronous), &
new_unittest('test_run_asynchronous', test_run_asynchronous), &
new_unittest('test_process_kill', test_process_kill), &
new_unittest('test_process_state', test_process_state), &
new_unittest('test_input_redirection', test_input_redirection) &
]
end subroutine collect_suite
!> Test running a synchronous process
subroutine test_run_synchronous(error)
type(error_type), allocatable, intent(out) :: error
type(process_type) :: process
character(len=*), parameter :: command = "echo Hello"
process = run(command, want_stdout=.true.)
call check(error, process%completed)
if (allocated(error)) return
call check(error, trim(process%stdout) == "Hello", "stdout=<"//trim(process%stdout)//">, expected ")
end subroutine test_run_synchronous
!> Test running an asynchronous process
subroutine test_run_asynchronous(error)
type(error_type), allocatable, intent(out) :: error
type(process_type) :: process
logical :: running
! The closest possible to a cross-platform command that waits
if (is_windows()) then
process = runasync("ping -n 2 127.0.0.1")
else
process = runasync("ping -c 2 127.0.0.1")
endif
! Should not be immediately completed
call check(error, .not. process%completed, "ping process should not complete immediately")
if (allocated(error)) return
running = is_running(process)
call check(error, running, "ping process should still be running immediately after started")
if (allocated(error)) return
call wait(process)
call check(error, process%completed, "process should be complete after `call wait`")
if (allocated(error)) return
call check(error, elapsed(process)>1.0e-4, "There should be a non-zero elapsed time")
end subroutine test_run_asynchronous
!> Test killing an asynchronous process
subroutine test_process_kill(error)
type(error_type), allocatable, intent(out) :: error
type(process_type) :: process
logical :: running, success
! Start a long-running process asynchronously
if (is_windows()) then
process = runasync("ping -n 10 127.0.0.1")
else
process = runasync("ping -c 10 127.0.0.1")
endif
! Ensure the process starts running
call check(error, .not. process%completed, "Process should not be completed immediately after starting")
if (allocated(error)) return
running = is_running(process)
call check(error, running, "Process should be running immediately after starting")
if (allocated(error)) return
! Kill the process
call kill(process, success)
call check(error, success, "Failed to kill the process")
if (allocated(error)) return
! Verify the process is no longer running
call check(error, .not. is_running(process), "Process should not be running after being killed")
if (allocated(error)) return
! Ensure process state updates correctly after killing
call check(error, process%completed, "Process should be marked as completed after being killed")
end subroutine test_process_kill
!> Test updating and checking process state
subroutine test_process_state(error)
type(error_type), allocatable, intent(out) :: error
type(process_type) :: process
character(len=*), parameter :: command = "echo Testing"
process = run(command, want_stdout=.true., want_stderr=.true.)
call update(process)
call check(error, process%completed)
if (allocated(error)) return
call check(error, process%exit_code == 0, "Check zero exit code")
if (allocated(error)) return
call check(error, len_trim(process%stderr) == 0, "Check no stderr output")
if (allocated(error)) return
call check(error, trim(process%stdout) == "Testing", "stdout=<"//trim(process%stdout)//">, expected ")
if (allocated(error)) return
end subroutine test_process_state
!> Test input redirection
subroutine test_input_redirection(error)
type(error_type), allocatable, intent(out) :: error
type(process_type) :: process
character(len=*), parameter :: input_string = "Hello Stdin"
if (is_windows()) then
! findstr "^" echoes input lines.
! Note: We need complex quoting because of how arguments are parsed.
! Actually, sticking to something simpler if possible.
! "more" implies paging which might hang. "sort" is usually safe.
process = run("sort", stdin=input_string, want_stdout=.true.)
else
process = run("cat", stdin=input_string, want_stdout=.true.)
endif
call check(error, process%completed, "Process did not complete")
if (allocated(error)) return
call check(error, process%exit_code == 0, "Process failed with non-zero exit code")
if (allocated(error)) return
! Check if output matches input (sort of "Hello Stdin" is "Hello Stdin")
call check(error, index(process%stdout, input_string) > 0, &
"Output <"//trim(process%stdout)//"> should contain <"//input_string//">")
end subroutine test_input_redirection
end module test_subprocess
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_subprocess, only : collect_suite
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("subprocess", collect_suite) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/intrinsics/ 0000775 0001750 0001750 00000000000 15135654166 021332 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/intrinsics/test_intrinsics.fypp 0000664 0001750 0001750 00000030144 15135654166 025460 0 ustar alastair alastair #:include "common.fypp"
#:set I_KINDS_TYPES = list(zip(INT_KINDS, INT_TYPES, INT_KINDS))
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
module test_intrinsics
use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test
use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64
use stdlib_intrinsics
use stdlib_linalg_state, only: linalg_state_type, LINALG_VALUE_ERROR, operator(==)
use stdlib_math, only: swap
implicit none
contains
!> Collect all exported unit tests
subroutine collect_suite(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest('sum', test_sum), &
new_unittest('dot_product', test_dot_product), &
new_unittest('matmul', test_matmul) &
]
end subroutine
subroutine test_sum(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
!> Internal parameters and variables
integer, parameter :: n = 1e3, ncalc = 3
real(sp) :: u
integer :: iter, i, j
!====================================================================================
#:for k, t, s in I_KINDS_TYPES
#:if not k in ["int8","int16"] # skip int8 and int16
block
${t}$, allocatable :: x(:)
${t}$, parameter :: total_sum = 0_${k}$
${t}$ :: xsum(ncalc), err(ncalc)
logical, allocatable :: mask(:), nmask(:)
allocate(x(n+1))
do i = 1, n+1
x(i) = i - n/2 - 1
end do
allocate(mask(n+1),source=.false.); mask(1:n+1:2) = .true.
allocate(nmask(n+1)); nmask = .not.mask
! scramble array
do i = 1, n+1
call random_number(u)
j = 1 + floor(n*u)
call swap( x(i), x(j) )
call swap( mask(i), mask(j) )
call swap( nmask(i), nmask(j) )
end do
xsum(1) = sum(x) ! compiler intrinsic
xsum(2) = stdlib_sum(x) ! chunked summation
err(1:2) = abs(total_sum-xsum(1:2))
call check(error, all(err(1:2)==0_${k}$) , "real sum is not accurate" )
if (allocated(error)) return
xsum(1) = sum(x,mask)+sum(x,nmask) ! compiler intrinsic
xsum(2) = stdlib_sum(x,mask)+stdlib_sum(x,nmask) ! chunked summation
err(1:2) = abs(total_sum-xsum(1:2))
call check(error, all(err(1:2)==0_${k}$) , "masked real sum is not accurate" )
if (allocated(error)) return
end block
#:endif
#:endfor
#:for k, t, s in R_KINDS_TYPES
block
${t}$, allocatable :: x(:)
${t}$, parameter :: total_sum = 4*atan(1._${k}$), tolerance = epsilon(1._${k}$)*100
${t}$ :: xsum(ncalc), err(ncalc)
logical, allocatable :: mask(:), nmask(:)
allocate(x(n))
do i = 1, n
x(i) = 8*atan(1._${k}$)*(real(i,kind=${k}$)-0.5_${k}$)/real(n,kind=${k}$)**2
end do
allocate(mask(n),source=.false.); mask(1:n:2) = .true.
allocate(nmask(n)); nmask = .not.mask
! scramble array
do i = 1, n
call random_number(u)
j = 1 + floor(n*u)
call swap( x(i), x(j) )
call swap( mask(i), mask(j) )
call swap( nmask(i), nmask(j) )
end do
xsum(1) = sum(x) ! compiler intrinsic
xsum(2) = stdlib_sum_kahan(x) ! chunked Kahan summation
xsum(3) = stdlib_sum(x) ! chunked summation
err(1:ncalc) = abs(1._${k}$-xsum(1:ncalc)/total_sum)
call check(error, all(err(:) sum all elements
call check(error, abs( sum(x) - stdlib_sum(x) ) sum over specific rank dim
do i = 1, rank(x)
call check(error, norm2( sum(x,dim=i) - stdlib_sum(x,dim=i) ) Error handling
type(error_type), allocatable, intent(out) :: error
!> Internal parameters and variables
integer, parameter :: n = 1e3, ncalc = 3
real(sp) :: u
integer :: iter, i, j
!====================================================================================
#:for k, t, s in R_KINDS_TYPES
block
${t}$, allocatable :: x(:)
${t}$, parameter :: total_sum = 4*atan(1._${k}$), tolerance = epsilon(1._${k}$)*100
${t}$ :: xsum(ncalc), err(ncalc)
allocate(x(n))
do i = 1, n
x(i) = 2*sqrt( 2*atan(1._${k}$)*(real(i,kind=${k}$)-0.5_${k}$) )/n
end do
! scramble array
do i = 1, n
call random_number(u)
j = 1 + floor(n*u)
call swap( x(i), x(j) )
end do
xsum(1) = dot_product(x,x) ! compiler intrinsic
xsum(2) = stdlib_dot_product_kahan(x,x) ! chunked Kahan summation
xsum(3) = stdlib_dot_product(x,x) ! chunked summation
err(1:ncalc) = abs(1._${k}$-xsum(1:ncalc)/total_sum)
call check(error, all(err(:) 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/intrinsics/CMakeLists.txt 0000664 0001750 0001750 00000000160 15135654166 024067 0 ustar alastair alastair set(
fppFiles
"test_intrinsics.fypp"
)
fypp_f90("${fyppFlags}" "${fppFiles}" outFiles)
ADDTEST(intrinsics)
fortran-lang-stdlib-0ede301/test/bitsets/ 0000775 0001750 0001750 00000000000 15135654166 020622 5 ustar alastair alastair fortran-lang-stdlib-0ede301/test/bitsets/test_stdlib_bitset_large.f90 0000664 0001750 0001750 00000134557 15135654166 026225 0 ustar alastair alastair module test_stdlib_bitset_large
use testdrive, only : new_unittest, unittest_type, error_type, check
use :: stdlib_kinds, only : int8, int16, int32, int64
use stdlib_bitsets, only: bitset_large, bits_kind&
, bits &
, success &
, and, and_not, or, xor&
, extract&
, assignment(=)&
, operator(<), operator(<=)&
, operator(>), operator(>=)&
, operator(/=), operator(==)
implicit none
character(*), parameter :: &
bitstring_0 = '000000000000000000000000000000000', &
bitstring_33 = '100000000000000000000000000000000', &
bitstring_all = '111111111111111111111111111111111'
contains
!> Collect all exported unit tests
subroutine collect_stdlib_bitset_large(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("string-operations", test_string_operations), &
new_unittest("io", test_io), &
new_unittest("initialization", test_initialization), &
new_unittest("bitset-assignment-array", test_assignment_array), &
new_unittest("bitset-inquiry", test_bitset_inquiry), &
new_unittest("bit-operations", test_bit_operations), &
new_unittest("bitset-comparisons", test_bitset_comparisons), &
new_unittest("bitset-operations", test_bitset_operations) &
]
end subroutine collect_stdlib_bitset_large
subroutine test_string_operations(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: status
character(:), allocatable :: string0
type(bitset_large) :: set0, set1, set3, set4
type(bitset_large) :: set10, set11, set13, set14
call set0 % from_string( bitstring_0 )
call check(error, bits(set0), 33, &
'from_string failed to interpret bitstring_0 size properly.')
if (allocated(error)) return
call check(error, set0 % none(), &
'failed to interpret bitstring_0 value properly.')
if (allocated(error)) return
call check(error, .not. set0 % any(), &
'failed to interpret bitstring_0 value properly.')
if (allocated(error)) return
call set10 % from_string( bitstring_0 // bitstring_0 )
call check(error, bits(set10), 66, &
'from_string failed to interpret bitstring_0 // bitstring_0 size properly.')
if (allocated(error)) return
call check(error, set10 % none(), &
'failed to interpret bitstring_0 // bitstring_0 value properly.')
if (allocated(error)) return
call check(error, .not. set10 % any(), &
'failed to interpret bitstring_0 // bitstring_0 value properly.')
if (allocated(error)) return
call set1 % from_string( bitstring_all )
call check(error, bits(set1), 33, &
'from_string failed to interpret bitstring_all size properly.')
if (allocated(error)) return
call check(error, .not. set1 % none(), &
'failed to interpret bitstring_all value properly.')
if (allocated(error)) return
call check(error, set1 % any(), &
'failed to interpret bitstring_all value properly.')
if (allocated(error)) return
call check(error, set1 % all(), &
'failed to interpret bitstring_all value properly.')
if (allocated(error)) return
call set11 % from_string( bitstring_all // bitstring_all )
call check(error, bits(set11), 66, &
'from_string failed to interpret bitstring_all // bitstring_all size properly.')
if (allocated(error)) return
call check(error, .not. set11 % none(), &
'failed to interpret bitstring_all // bitstring_all value properly.')
if (allocated(error)) return
call check(error, set11 % any(), &
'failed to interpret bitstring_all // bitstring_all value properly.')
if (allocated(error)) return
call check(error, set11 % all(), &
'failed to interpret bitstring_all // bitstring_all value properly.')
if (allocated(error)) return
call set3 % read_bitset( bitstring_0, status )
call check(error, status /= success, &
'read_bitset_string did not fail with bitstring_0 as expected.')
if (allocated(error)) return
call set13 % read_bitset( bitstring_0 // bitstring_0, status )
call check(error, status /= success, &
'read_bitset_string did not fail with bitstring_0 // bitstring_0 as expected.')
if (allocated(error)) return
call set3 % read_bitset( 's33b' // bitstring_0, status )
call check(error, bits(set3), 33, &
'read_bitset_string failed to interpret "s33b" // bitstring_0 size properly.')
if (allocated(error)) return
call check(error, set3 % none(), &
'failed to interpret "s33b" // bitstring_0 value properly.')
if (allocated(error)) return
call set13 % read_bitset( 's66b' // bitstring_0 // bitstring_0, &
status )
call check(error, bits(set13), 66, 'read_bitset_string failed to ' // &
'interpret "s66b" // bitstring_0 // bitstring_0 size properly.')
if (allocated(error)) return
call check(error, set13 % none(), &
'failed to interpret "s66b" // bitstring_0 // bitstring_0 value properly.')
if (allocated(error)) return
call set4 % read_bitset( 's33b' // bitstring_all )
call check(error, bits(set4), 33, &
'read_bitset_string failed to interpret "s33b" // bitstring_all size properly.')
if (allocated(error)) return
call check(error, .not. set4 % none(), &
'read_bitset_string failed to interpret "s33b" // bitstring_all value properly.')
if (allocated(error)) return
call check(error, set4 % any(), &
'read_bitset_string failed to // interpret "s33b" bitstring_all value properly.')
if (allocated(error)) return
call check(error, set4 % all(), &
'read_bitset_string failed to // interpret "s33b" bitstring_all value properly.')
if (allocated(error)) return
call set14 % read_bitset( 's66b' // bitstring_all // bitstring_all )
call check(error, bits(set14), 66, &
'read_bitset_string failed to ' // &
'interpret "s66b" // bitstring_all // bitstring_all size properly.')
if (allocated(error)) return
call check(error, .not. set14 % none(), 'read_bitset_string failed to ' // &
'interpret "s66b" // bitstring_all // bitstring_all value properly.')
if (allocated(error)) return
call check(error, set14 % any(), 'read_bitset_string failed to // ' // &
'interpret "s66b" bitstring_all // bitstring_all value properly.')
if (allocated(error)) return
call check(error, set14 % all(), 'read_bitset_string failed to // ' // &
'interpret "s66b" bitstring_all // bitstring_all value properly.')
if (allocated(error)) return
call set0 % to_string( string0 )
call check(error, bitstring_0, string0, &
'to_string failed to convert set0 value properly.')
if (allocated(error)) return
call set10 % to_string( string0 )
call check(error, bitstring_0 // bitstring_0, string0, &
'to_string failed to convert set10 value properly.')
if (allocated(error)) return
call set1 % to_string( string0 )
call check(error, bitstring_all, string0, &
'to_string failed to convert set1 value properly.')
if (allocated(error)) return
call set11 % to_string( string0 )
call check(error, bitstring_all // bitstring_all, string0, &
'to_string failed to convert set11 value properly.')
if (allocated(error)) return
call set0 % write_bitset( string0 )
call check(error, ('S33B' // bitstring_0), string0, &
'write_bitset_string failed to convert set2 value properly.')
if (allocated(error)) return
call set10 % write_bitset( string0 )
call check(error, ('S66B' // bitstring_0 // bitstring_0), string0, &
'write_bitset_string failed to convert set10 value properly.')
if (allocated(error)) return
call set1 % write_bitset( string0 )
call check(error, ('S33B' // bitstring_all), string0, &
'write_bitset_string failed to convert set1 value properly.')
if (allocated(error)) return
call set11 % write_bitset( string0 )
call check(error, ('S66B' // bitstring_all // bitstring_all), string0, &
'write_bitset_string failed to convert set11 value properly.')
if (allocated(error)) return
end subroutine test_string_operations
subroutine test_io(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: unit
type(bitset_large) :: set0, set1, set2, set3, set4, set5
type(bitset_large) :: set10, set11, set12, set13, set14, set15
call set0 % from_string( bitstring_0 )
call set1 % from_string( bitstring_all )
call set2 % from_string( bitstring_33 )
open( newunit=unit, status='scratch', form='formatted', &
action='readwrite' )
call set2 % write_bitset(unit)
call set1 % write_bitset(unit)
call set0 % write_bitset(unit)
rewind( unit )
call set3 % read_bitset(unit)
call set5 % read_bitset(unit)
call set4 % read_bitset(unit)
call check(error, set4 == set0 .and. set5 == set1 .and. set3 == set2, &
'transfer to and from units using bitset literals failed.')
if (.not.allocated(error)) then
rewind( unit )
call set10 % from_string( bitstring_0 // bitstring_0 )
call set11 % from_string( bitstring_all // bitstring_all )
call set12 % from_string( bitstring_33 // bitstring_33 )
call set12 % write_bitset(unit)
call set11 % write_bitset(unit)
call set10 % write_bitset(unit)
rewind( unit )
call set13 % read_bitset(unit)
call set15 % read_bitset(unit)
call set14 % read_bitset(unit)
call check(error, set14 == set10 .and. set15 == set11 .and. set3 == set12, &
'transfer to and from units using bitset literals for bits > 64 failed.')
end if
if (.not.allocated(error)) then
rewind( unit )
call set2 % write_bitset(unit, advance='no')
call set1 % write_bitset(unit, advance='no')
call set0 % write_bitset(unit)
rewind( unit )
call set3 % read_bitset(unit, advance='no')
call set4 % read_bitset(unit, advance='no')
call set5 % read_bitset(unit)
call check(error, set5 == set0 .and. set4 == set1 .and. set3 == set2, &
'transfer to and from units using bitset literals with advance == "no" failed.')
end if
if (.not.allocated(error)) then
rewind( unit )
call set12 % write_bitset(unit, advance='no')
call set11 % write_bitset(unit, advance='no')
call set10 % write_bitset(unit)
rewind( unit )
call set13 % read_bitset(unit, advance='no')
call set14 % read_bitset(unit, advance='no')
call set15 % read_bitset(unit)
call check(error, set15 == set10 .and. set14 == set11 .and. set13 == set12, &
'transfer to and from units using bitset literals for bitss > 64 with advance == "no" failed.')
end if
close(unit)
if (allocated(error)) return
open( newunit=unit, form='unformatted', status='scratch', &
action='readwrite' )
call set2 % output(unit)
call set1 % output(unit)
call set0 % output(unit)
rewind( unit )
call set5 % input(unit)
call set4 % input(unit)
call set3 % input(unit)
call check(error, set3 == set0 .and. set4 == set1 .and. set5 == set2, &
'transfer to and from units using output and input failed.')
close( unit )
if (allocated(error)) return
open( newunit=unit, form='unformatted', access='stream', &
status='scratch', action='readwrite' )
call set2 % output(unit)
call set1 % output(unit)
call set0 % output(unit)
rewind( unit )
call set5 % input(unit)
call set4 % input(unit)
call set3 % input(unit)
call check(error, set3 == set0 .and. set4 == set1 .and. set5 == set2, &
'transfer to and from units using stream output and input failed.')
close( unit )
if (allocated(error)) return
open( newunit=unit, form='unformatted', status='scratch', &
action='readwrite' )
call set12 % output(unit)
call set11 % output(unit)
call set10 % output(unit)
rewind( unit )
call set15 % input(unit)
call set14 % input(unit)
call set13 % input(unit)
call check(error, set13 == set10 .and. set14 == set11 .and. set15 == set12, &
'transfer to and from units using output and input failed for bits . 64.')
close(unit)
if (allocated(error)) return
open( newunit=unit, form='unformatted', access='stream', &
status='scratch', action='readwrite' )
call set12 % output(unit)
call set11 % output(unit)
call set10 % output(unit)
rewind( unit )
call set15 % input(unit)
call set14 % input(unit)
call set13 % input(unit)
call check(error, set13 == set10 .and. set14 == set11 .and. set15 == set12, &
'transfer to and from units using stream output and input failed for bits . 64.')
close(unit)
if (allocated(error)) return
end subroutine test_io
subroutine test_initialization(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical(int8) :: log1(64) = .true.
logical(int16) :: log2(31) = .false.
logical(int32) :: log3(15) = .true.
logical(int64) :: log4(33) = .false.
logical(int8) :: log11(66) = .true.
logical(int16) :: log12(99) = .false.
logical(int32) :: log13(132) = .true.
logical(int64) :: log14(165) = .false.
logical(int8), allocatable :: log5(:)
logical(int16), allocatable :: log6(:)
logical(int32), allocatable :: log7(:)
logical(int64), allocatable :: log8(:)
type(bitset_large) :: set4, set5
!The following triggers an issue in gfortran 11 and 12
block
type(bitset_large) :: set6
call check(error, set6 % bits(), 0, &
'set6 % bits() returned non-zero value '//&
'even though set6 was not initialized.')
if (allocated(error)) return
end block
set5 = log1
call check(error, set5 % bits(), 64, &
' initialization with logical(int8) failed to set' // &
' the right size.')
if (allocated(error)) return
call check(error, set5 % all(), &
' initialization with' // &
' logical(int8) failed to set the right values.')
if (allocated(error)) return
set5 = log11
call check(error, set5 % bits(), 66, &
' initialization with logical(int8) failed to set' // &
' the right size > 64 bits.')
if (allocated(error)) return
call check(error, set5 % all(), &
' initialization with' // &
' logical(int8) failed to set the right values.')
if (allocated(error)) return
set5 = log2
call check(error, set5 % bits(), 31, &
' initialization with logical(int16) failed to set' // &
' the right size.')
if (allocated(error)) return
call check(error, set5 % none(), &
' initialization with logical(int16) failed to set' // &
' the right values.')
if (allocated(error)) return
set5 = log12
call check(error, set5 % bits(), 99, &
' initialization with logical(int16) failed to set' // &
' the right size > 64 bits .')
if (allocated(error)) return
call check(error, set5 % none(), &
' initialization with logical(int16) failed to set' // &
' the right values > 64 bits .')
if (allocated(error)) return
set5 = log3
call check(error, set5 % bits(), 15, &
' initialization with logical(int32) failed to set' // &
' the right size.')
if (allocated(error)) return
call check(error, set5 % all(), &
' initialization with logical(int32) failed to set' // &
' the right values.')
if (allocated(error)) return
set5 = log13
call check(error, set5 % bits(), 132, &
' initialization with logical(int32) failed to set' // &
' the right size > 64 bits .')
if (allocated(error)) return
call check(error, set5 % all(), &
' initialization with logical(int32) failed to set' // &
' the right values > 64 bits .')
if (allocated(error)) return
set5 = log4
call check(error, set5 % bits(), 33, &
' initialization with logical(int64) failed to set' // &
' the right size.')
if (allocated(error)) return
call check(error, set5 % none(), &
' initialization with logical(int64) failed to set' // &
' the right values.')
if (allocated(error)) return
set5 = log14
call check(error, set5 % bits(), 165, &
' initialization with logical(int64) failed to set' // &
' the right size > 64 bits .')
if (allocated(error)) return
call check(error, set5 % none(), &
' initialization with logical(int64) failed to set' // &
' the right values > 64 bits .')
if (allocated(error)) return
set5 = log1
call extract( set4, set5, 1_bits_kind, 33_bits_kind )
call check(error, set4 % bits(), 33, &
' initialization with extract failed to set' // &
' the right size.')
if (allocated(error)) return
call check(error, set4 % all(), &
' initialization with extract failed to set' // &
' the right values.')
if (allocated(error)) return
set5 = log11
call extract( set4, set5, 1_bits_kind, 65_bits_kind )
call check(error, set4 % bits(), 65, &
' initialization with extract failed to set' // &
' the right size > 64 bits.')
if (allocated(error)) return
call check(error, set4 % all(), &
' initialization with extract failed to set' // &
' the right values > 64 bits.')
if (allocated(error)) return
set5 = log1
set4 = set5
call check(error, set4 % bits(), 64, &
' initialization with simple assignment failed to set' // &
' the right size.')
if (allocated(error)) return
call check(error, set4 % all(), &
' initialization with simple assignment failed to set' // &
' the right values.')
if (allocated(error)) return
set5 = log11
set4 = set5
call check(error, set4 % bits(), 66, &
' initialization with simple assignment failed to set' // &
' the right size > 64 bits.')
if (allocated(error)) return
call check(error, set4 % all(), &
' initialization with simple assignment failed to set' // &
' the right values > 64 bits.')
if (allocated(error)) return
set5 = log1
log5 = set5
call check(error, size(log5), 64, &
' initialization of logical(int8) with assignment failed' // &
' to set the right size.')
if (allocated(error)) return
call check(error, all(log5) .eqv. .true., & ! FIXME
' initialization of logical(int8) with assignment failed' // &
' to set the right values.')
if (allocated(error)) return
set5 = log11
log5 = set5
call check(error, size(log5), 66, &
' initialization of logical(int8) with assignment failed' // &
' to set the right size > 64 bits.')
if (allocated(error)) return
call check(error, all(log5) .eqv. .true., & ! FIXME
' initialization of logical(int8) with assignment failed' // &
' to set the right values > 64 bits.')
if (allocated(error)) return
set5 = log1
log6 = set5
call check(error, size(log6), 64, &
' initialization of logical(int16) with assignment failed' // &
' to set the right size.')
if (allocated(error)) return
call check(error, all(log6) .eqv. .true., & ! FIXME
' initialization of logical(int16) with assignment failed' // &
' to set the right values.')
if (allocated(error)) return
set5 = log11
log6 = set5
call check(error, size(log6), 66, &
' initialization of logical(int16) with assignment failed' // &
' to set the right size > 64 bits.')
if (allocated(error)) return
call check(error, all(log6) .eqv. .true., & ! FIXME
' initialization of logical(int16) with assignment failed' // &
' to set the right values > 64 bits.')
if (allocated(error)) return
set5 = log1
log7 = set5
call check(error, size(log7), 64, &
' initialization of logical(int32) with assignment failed' // &
' to set the right size.')
if (allocated(error)) return
call check(error, all(log7), &
' initialization of logical(int32) with assignment failed' // &
' to set the right values.')
if (allocated(error)) return
set5 = log11
log7 = set5
call check(error, size(log7), 66, &
' initialization of logical(int32) with assignment failed' // &
' to set the right size > 64 bits.')
if (allocated(error)) return
call check(error, all(log7), &
' initialization of logical(int32) with assignment failed' // &
' to set the right values > 64 bits.')
if (allocated(error)) return
set5 = log1
log8 = set5
call check(error, size(log8), 64, &
' initialization of logical(int64) with assignment failed' // &
' to set the right size.')
if (allocated(error)) return
call check(error, merge(.true., .false., all(log8)), & ! FIXME
' initialization of logical(int64) with assignment failed' // &
' to set the right values.')
if (allocated(error)) return
set5 = log11
log8 = set5
call check(error, size(log8), 66, &
' initialization of logical(int64) with assignment failed' // &
' to set the right size > 64 bits.')
if (allocated(error)) return
call check(error, merge(.true., .false., all(log8)), & ! FIXME
' initialization of logical(int64) with assignment failed' // &
' to set the right values > 64 bits.')
if (allocated(error)) return
end subroutine test_initialization
subroutine test_assignment_array(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical(int8) :: log1(64) = .true.
integer :: i
type(bitset_large) :: set1(0:4)
do i = 0, size(set1) - 1
set1(i) = log1
enddo
do i = 0, size(set1) - 1
call check(error, set1(i) % bits(), 64, &
' initialization with logical(int8) failed to set' // &
' the right size in a bitset array.')
if (allocated(error)) return
enddo
!Test added following issue https://github.com/fortran-lang/stdlib/issues/726
set1(0) = set1(0)
call check(error, set1(0) % bits(), 64, &
' initialization from bitset_large failed to set' // &
' the right size in a bitset array.')
if (allocated(error)) return
end subroutine test_assignment_array
subroutine test_bitset_inquiry(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(bits_kind) :: i
type(bitset_large) :: set0, set1
type(bitset_large) :: set10, set11
call set0 % from_string( bitstring_0 )
call set1 % from_string( bitstring_all )
call check(error, set0 % none(), &
' set0 did not have none set which was unexpected')
if (allocated(error)) return
call check(error, .not. set0 % any(), &
' set0 had some bits set which was unexpected.')
if (allocated(error)) return
call set0 % not()
call check(error, set0 % all(), &
' set0 did not have all bits set which was unexpected')
if (allocated(error)) return
call check(error, set0 % any(), &
' set0 had no bits set which was unexpected.')
if (allocated(error)) return
call check(error, set1 % any(), &
' set1 had none bits set which was unexpected')
if (allocated(error)) return
call check(error, set1 % all(), &
' set1 did not have all bits set which was unexpected.')
if (allocated(error)) return
call set0 % not()
do i=0, set0 % bits() - 1
call check(error, .not. set0 % test(i), &
'against expectations set0 has at least 1 bit set.')
if (allocated(error)) return
end do
do i=0, set1 % bits() - 1
call check(error, set1 % test(i), &
'against expectations set0 has at least 1 bit unset.')
if (allocated(error)) return
end do
do i=0, set0 % bits() - 1
call check(error, set0 % value(i), 0, &
'against expectations set0 has at least 1 bit set.')
if (allocated(error)) return
end do
do i=0, set1 % bits() - 1
call check(error, set1 % value(i), 1, &
'against expectations set0 has at least 1 bit unset.')
if (allocated(error)) return
end do
call check(error, set0 % bits() == 33, &
'set0 unexpectedly does not have 33 bits.')
if (allocated(error)) return
! > 64 bit inquiries
call set10 % from_string( bitstring_0 // bitstring_0 // bitstring_0 )
call check(error, set10 % none(), &
' set10 did not have none set which was unexpected')
if (allocated(error)) return
call check(error, .not. set10 % any(), &
' set10 had some bits set which was unexpected.')
if (allocated(error)) return
call set10 % not()
call check(error, set10 % all(), &
' set10 did not have all bits set which was unexpected')
if (allocated(error)) return
call check(error, set10 % any(), &
' set10 had no bits set which was unexpected.')
if (allocated(error)) return
call set11 % from_string( bitstring_all // bitstring_all // &
bitstring_all )
call check(error, set11 % any(), &
' set11 had none bits set which was unexpected')
if (allocated(error)) return
call check(error, set11 % all(), &
' set11 did not have all bits set which was unexpected.')
if (allocated(error)) return
call set10 % not()
do i=0, set10 % bits() - 1
call check(error, .not. set10 % test(i), &
'against expectations set10 has at least 1 bit set.')
if (allocated(error)) return
end do
do i=0, set11 % bits() - 1
call check(error, set11 % test(i), &
'against expectations set11 has at least 1 bit unset.')
if (allocated(error)) return
end do
do i=0, set10 % bits() - 1
call check(error, set10 % value(i), 0, &
'against expectations set10 has at least 1 bit set.')
if (allocated(error)) return
end do
do i=0, set11 % bits() - 1
call check(error, set11 % value(i), 1, &
'against expectations set11 has at least 1 bit unset.')
if (allocated(error)) return
end do
call check(error, set0 % bits() == 33, &
'set0 unexpectedly does not have 33 bits.')
if (allocated(error)) return
call check(error, set10 % bits() == 99, &
'set10 unexpectedly does not have 99 bits.')
if (allocated(error)) return
end subroutine test_bitset_inquiry
subroutine test_bit_operations(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_large) :: set1, set11
call set1 % from_string( bitstring_all )
call check(error, set1 % all(), &
'set1 is not all set.')
if (allocated(error)) return
call set1 % clear(0_bits_kind)
call check(error, .not. set1 % test(0_bits_kind), &
'did not clear the first bit in set1.')
if (allocated(error)) return
call check(error, set1 % test(1_bits_kind), &
'cleared more than one bit in set1.')
if (allocated(error)) return
call set1 % clear(1_bits_kind, 32_bits_kind)
call check(error, set1 % none(), &
'did not clear remaining bits in set1.')
if (allocated(error)) return
call set1 % flip(0_bits_kind)
call check(error, set1 % test(0_bits_kind), &
'did not flip the first bit in set1.')
if (allocated(error)) return
call check(error, .not. set1 % test(1_bits_kind), &
'flipped more than one bit in set1.')
if (allocated(error)) return
call set1 % flip(1_bits_kind, 32_bits_kind)
call check(error, set1 % all(), &
'did not flip remaining bits in set1.')
if (allocated(error)) return
call set1 % not()
call check(error, set1 % none(), &
'did not unset bits in set1.')
if (allocated(error)) return
call set1 % set(0_bits_kind)
call check(error, set1 % test(0_bits_kind), &
'did not set the first bit in set1.')
if (allocated(error)) return
call check(error, .not. set1 % test(1_bits_kind), &
'set more than one bit in set1.')
if (allocated(error)) return
call set1 % set(1_bits_kind, 32_bits_kind)
call check(error, set1 % all(), &
'did not set the remaining bits in set1.')
if (allocated(error)) return
call set11 % init( 166_bits_kind )
call set11 % not()
call check(error, set11 % all(), &
'set11 is not all set.')
if (allocated(error)) return
call set11 % clear(0_bits_kind)
call check(error, .not. set11 % test(0_bits_kind), &
'did not clear the first bit in set11.')
if (allocated(error)) return
call check(error, set11 % test(1_bits_kind), &
'cleared more than one bit in set11.')
if (allocated(error)) return
call set11 % clear(165_bits_kind)
call check(error, .not. set11 % test(165_bits_kind), &
'did not clear the last bit in set11.')
if (allocated(error)) return
call check(error, set11 % test(164_bits_kind), &
'cleared more than one bit in set11.')
if (allocated(error)) return
call set11 % clear(1_bits_kind, 164_bits_kind)
call check(error, set11 % none(), &
'did not clear remaining bits in set11.')
if (allocated(error)) return
call set11 % flip(0_bits_kind)
call check(error, set11 % test(0_bits_kind), &
'did not flip the first bit in set11.')
if (allocated(error)) return
call check(error, .not. set11 % test(1_bits_kind), &
'flipped more than one bit in set11.')
if (allocated(error)) return
call set11 % flip(165_bits_kind)
call check(error, set11 % test(165_bits_kind), &
'did not flip the last bit in set11.')
if (allocated(error)) return
call check(error, .not. set11 % test(164_bits_kind), &
'flipped more than one bit in set11.')
if (allocated(error)) return
call set11 % flip(1_bits_kind, 164_bits_kind)
call check(error, set11 % all(), &
'did not flip remaining bits in set11.')
if (allocated(error)) return
call set11 % not()
call check(error, set11 % none(), &
'did not unset bits in set11.')
if (allocated(error)) return
call set11 % set(0_bits_kind)
call check(error, set11 % test(0_bits_kind), &
'did not set the first bit in set11.')
if (allocated(error)) return
call check(error, .not. set11 % test(1_bits_kind), &
'set more than one bit in set11.')
if (allocated(error)) return
call set11 % set(165_bits_kind)
call check(error, set11 % test(165_bits_kind), &
'did not set the last bit in set11.')
if (allocated(error)) return
call check(error, .not. set11 % test(164_bits_kind), &
'set more than one bit in set11.')
if (allocated(error)) return
call set11 % set(1_bits_kind, 164_bits_kind)
call check(error, set11 % all(), &
'did not set the remaining bits in set11.')
if (allocated(error)) return
end subroutine test_bit_operations
subroutine test_bitset_comparisons(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_large) :: set0, set1, set2
type(bitset_large) :: set10, set11, set12, set13, set14
call set0 % from_string( bitstring_0 )
call set1 % from_string( bitstring_all )
call set2 % from_string( bitstring_33 )
call check(error, set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. &
.not. set0 == set1 .and. .not. set0 == set2 .and. .not. &
set1 == set2, 'failed 64 bit equality tests.')
if (allocated(error)) return
call check(error, set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. &
.not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. &
set2 /= set2, 'failed 64 bit inequality tests.')
if (allocated(error)) return
call check(error, set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. &
.not. set0 > set1 .and. .not. set1 > set1 .and. .not. &
set2 > set1, 'failed 64 bit greater than tests.')
if (allocated(error)) return
call check(error, set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. &
.not. set0 >= set1 .and. .not. set0 >= set1 .and. .not. &
set2 >= set1, 'failed 64 bit greater than or equal tests.')
if (allocated(error)) return
call check(error, set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. &
.not. set1 < set0 .and. .not. set0 < set0 .and. .not. &
set1 < set2, 'failed 64 bit less than tests.')
if (allocated(error)) return
call check(error, set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. &
.not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. &
set1 <= set2, 'failed 64 bit less than or equal tests.')
if (allocated(error)) return
call set10 % init(166_bits_kind)
call set11 % init(166_bits_kind)
call set11 % not()
call set12 % init(166_bits_kind)
call set12 % set(165_bits_kind)
call set13 % init(166_bits_kind)
call set13 % set(65_bits_kind)
call set14 % init(166_bits_kind)
call set14 % set(0_bits_kind)
call check(error, set10 == set10 .and. set11 == set11 .and. set12 == set12 .and. &
set13 == set13 .and. set14 == set14 .and. &
.not. set13 == set14 .and. .not. set12 == set13 .and. &
.not. set10 == set11 .and. .not. set10 == set12 .and. .not. &
set11 == set12, 'failed > 64 bit equality tests.')
if (allocated(error)) return
call check(error, set10 /= set11 .and. set11 /= set12 .and. set10 /= set12 .and. &
set13 /= set12 .and. set14 /= set13 .and. set14 /= set12 .and. &
.not. set13 /= set13 .and. .not. set12 /= set12 .and. &
.not. set10 /= set10 .and. .not. set11 /= set11 .and. .not. &
set12 /= set12, 'failed > 64 bit inequality tests.')
if (allocated(error)) return
call check(error, set11 > set10 .and. set12 > set10 .and. set11 > set12 .and. &
set13 > set14 .and. set12 > set13 .and. set12 > set14 .and. &
.not. set14 > set12 .and. .not. set12 > set11 .and. &
.not. set10 > set11 .and. .not. set11 > set11 .and. .not. &
set12 > set11, 'failed > 64 bit greater than tests.')
if (allocated(error)) return
call check(error, set11 >= set10 .and. set11 >= set12 .and. set12 >= set12 .and. &
set13 >= set14 .and. set12 >= set13 .and. set12 >= set14 .and. &
.not. set14 >= set12 .and. .not. set12 >= set11 .and. &
.not. set10 >= set11 .and. .not. set10 >= set11 .and. .not. &
set12 >= set11, 'failed 64 bit greater than or equal tests.')
if (allocated(error)) return
call check(error, set10 < set11 .and. set10 < set11 .and. set12 < set11 .and. &
set14 < set13 .and. set13 < set12 .and. set14 < set12 .and. &
.not. set12 < set14 .and. .not. set11 < set12 .and. &
.not. set11 < set10 .and. .not. set10 < set10 .and. .not. &
set11 < set12, 'failed > 64 bit less than tests.')
if (allocated(error)) return
call check(error, set10 <= set11 .and. set12 <= set11 .and. set12 <= set12 .and. &
set14 <= set13 .and. set13 <= set12 .and. set14 <= set12 .and. &
.not. set12 <= set14 .and. .not. set11 <= set12 .and. &
.not. set11 <= set10 .and. .not. set12 <= set10 .and. .not. &
set11 <= set12, 'failed > 64 bit less than or equal tests.')
if (allocated(error)) return
end subroutine test_bitset_comparisons
subroutine test_bitset_operations(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_large) :: set0, set3, set4
call set0 % from_string( bitstring_all )
call set4 % from_string( bitstring_all )
call and( set0, set4 ) ! all all
call check(error, set0 % all(), 'first test of < 64 bit AND failed.')
if (allocated(error)) return
call set4 % from_string( bitstring_0 )
call and( set0, set4 ) ! all none
call check(error, set0 % none(), 'second test of < 64 bit AND failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_all )
call set4 % from_string( bitstring_0 )
call and( set4, set3 ) ! none all
call check(error, set4 % none(), 'third test of < 64 bit AND failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_0 )
call and( set4, set3 ) ! none none
call check(error, set4 % none(), 'fourth test of < 64 bit AND failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_all )
call set4 % from_string( bitstring_all )
call and_not( set4, set3 ) ! all all
call check(error, set4 % none(), 'first test of < 64 bit AND_NOT failed.')
if (allocated(error)) return
call set4 % from_string( bitstring_0 )
call and_not( set4, set3 ) ! none all
call check(error, set4 % none(), 'second test of < 64 bit AND_NOT failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_all )
call set4 % from_string( bitstring_0 )
call and_not( set3, set4 ) ! all none
call check(error, set3 % all(), 'third test of < 64 bit AND_NOT failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_0 )
call set4 % from_string( bitstring_0 )
call and_not( set3, set4 ) ! none none
call check(error, set3 % none(), 'fourth test of < 64 bit AND_NOT failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_all )
call set4 % from_string( bitstring_all )
call or( set3, set4 ) ! all all
call check(error, set3 % all(), 'first test of < 64 bit OR failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_0 )
call or( set4, set3 ) ! all none
call check(error, set4 % all(), 'second test of < 64 bit OR failed.')
if (allocated(error)) return
call or( set3, set4 ) ! none all
call check(error, set3 % all(), 'third test of < 64 bit OR failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_0 )
call set4 % from_string( bitstring_0 )
call or( set4, set3 ) !none none
call check(error, set4 % none(), 'fourth test of < 64 bit OR failed.')
if (allocated(error)) return
call set3 % from_string( bitstring_0 )
call set4 % from_string( bitstring_0 )
call xor( set3, set4 ) ! none none
call check(error, set3 % none(), 'first test of < 64 bit XOR failed.')
if (allocated(error)) return
call set4 % from_string( bitstring_all )
call xor( set3, set4 ) ! none all
call check(error, set3 % all(), 'second test of < 64 bit XOR failed.')
if (allocated(error)) return
call set4 % from_string( bitstring_0 )
call xor( set3, set4 ) ! all none
call check(error, set3 % all(), 'third test of < 64 bit XOR failed.')
if (allocated(error)) return
call set4 % from_string( bitstring_all )
call xor( set3, set4 ) ! all all
call check(error, set3 % none(), 'fourth test of < 64 bit XOR failed.')
if (allocated(error)) return
call set0 % init(166_bits_kind)
call set0 % not()
call set4 % init(166_bits_kind)
call set4 % not()
call and( set0, set4 ) ! all all
call check(error, set0 % all(), 'first test of > 64 bit AND failed.')
if (allocated(error)) return
call set4 % init(166_bits_kind)
call and( set0, set4 ) ! all none
call check(error, set0 % none(), 'second test of > 64 bit AND failed.')
if (allocated(error)) return
call set3 % init(166_bits_kind)
call set3 % not()
call and( set4, set3 ) ! none all
call check(error, set4 % none(), 'third test of > 64 bit AND failed.')
if (allocated(error)) return
call set3 % init(166_bits_kind)
call and( set4, set3 ) ! none none
call check(error, set4 % none(), 'fourth test of > 64 bit AND failed.')
if (allocated(error)) return
call set3 % not()
call set4 % not()
call and_not( set4, set3 ) ! all all
call check(error, set4 % none(), 'first test of > 64 bit AND_NOT failed.')
if (allocated(error)) return
call and_not( set4, set3 ) ! none all
call check(error, set4 % none(), 'second test of > 64 bit AND_NOT failed.')
if (allocated(error)) return
call and_not( set3, set4 ) ! all none
call check(error, set3 % all(), 'third test of > 64 bit AND_NOT failed.')
if (allocated(error)) return
call set3 % not()
call and_not( set3, set4 ) ! none none
call check(error, set3 % none(), 'fourth test of > 64 bit AND_NOT failed.')
if (allocated(error)) return
call set3 % init(166_bits_kind)
call set3 % not()
call set4 % init(166_bits_kind)
call set4 % not()
call or( set3, set4 ) ! all all
call check(error, set3 % all(), 'first test of > 64 bit OR failed.')
if (allocated(error)) return
call set3 % init(166_bits_kind)
call or( set4, set3 ) ! all none
call check(error, set4 % all(), 'second test of > 64 bit OR failed.')
if (allocated(error)) return
call or( set3, set4 ) ! none all
call check(error, set3 % all(), 'third test of > 64 bit OR failed.')
if (allocated(error)) return
call set3 % init(166_bits_kind)
call set4 % init(166_bits_kind)
call or( set4, set3 ) !none none
call check(error, set4 % none(), 'fourth test of > 64 bit OR failed.')
if (allocated(error)) return
call xor( set3, set4 ) ! none none
call check(error, set3 % none(), 'first test of > 64 bit XOR failed.')
if (allocated(error)) return
call set4 % not()
call xor( set3, set4 ) ! none all
call check(error, set3 % all(), 'second test of > 64 bit XOR failed.')
if (allocated(error)) return
call set4 % not()
call xor( set3, set4 ) ! all none
call check(error, set3 % all(), 'third test of > 64 bit XOR failed.')
if (allocated(error)) return
call set4 % not()
call xor( set3, set4 ) ! all all
call check(error, set3 % none(), 'fourth test of > 64 bit XOR failed.')
if (allocated(error)) return
end subroutine test_bitset_operations
end module test_stdlib_bitset_large
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_stdlib_bitset_large, only : collect_stdlib_bitset_large
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("stdlib-bitset-large", collect_stdlib_bitset_large) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/test/bitsets/CMakeLists.txt 0000664 0001750 0001750 00000000070 15135654166 023357 0 ustar alastair alastair ADDTEST(stdlib_bitset_64)
ADDTEST(stdlib_bitset_large)
fortran-lang-stdlib-0ede301/test/bitsets/test_stdlib_bitset_64.f90 0000664 0001750 0001750 00000054307 15135654166 025356 0 ustar alastair alastair module test_stdlib_bitset_64
use testdrive, only : new_unittest, unittest_type, error_type, check
use :: stdlib_kinds, only : int8, int16, int32, int64
use stdlib_bitsets
implicit none
private
public :: collect_stdlib_bitset_64
character(*), parameter :: &
bitstring_0 = '000000000000000000000000000000000', &
bitstring_33 = '100000000000000000000000000000000', &
bitstring_all = '111111111111111111111111111111111'
contains
!> Collect all exported unit tests
subroutine collect_stdlib_bitset_64(testsuite)
!> Collection of tests
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("string-operations-0", test_string_operations_0), &
new_unittest("string-operations-1", test_string_operations_1), &
new_unittest("string-operations-3", test_string_operations_3), &
new_unittest("string-operations-4", test_string_operations_4), &
new_unittest("io", test_io), &
new_unittest("initialization", test_initialization), &
new_unittest("bitset-inquiry", test_bitset_inquiry), &
new_unittest("bit-operations", test_bit_operations), &
new_unittest("bitset-comparisons", test_bitset_comparisons), &
new_unittest("bitset-operations-and", test_bitset_operations_and), &
new_unittest("bitset-operations-nand", test_bitset_operations_nand), &
new_unittest("bitset-operations-or", test_bitset_operations_or), &
new_unittest("bitset-operations-xor", test_bitset_operations_xor) &
]
end subroutine collect_stdlib_bitset_64
subroutine test_string_operations_0(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set
character(:), allocatable :: string0
call set%from_string(bitstring_0)
call check(error, bits(set), 33)
if (allocated(error)) return
call check(error, set%none())
if (allocated(error)) return
call check(error, .not.set%any())
if (allocated(error)) return
call set%to_string(string0)
call check(error, string0, bitstring_0)
if (allocated(error)) return
call set%write_bitset(string0)
call check(error, string0, ('S33B' // bitstring_0))
if (allocated(error)) return
end subroutine test_string_operations_0
subroutine test_string_operations_1(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set
character(:), allocatable :: string0
call set%from_string(bitstring_all)
call check(error, bits(set), 33)
if (allocated(error)) return
call check(error, .not.set%none() )
if (allocated(error)) return
call check(error, set%any() )
if (allocated(error)) return
call check(error, set%all() )
if (allocated(error)) return
call set%to_string(string0)
call check(error, string0, bitstring_all)
if (allocated(error)) return
call set%write_bitset(string0)
call check(error, string0, ('S33B' // bitstring_all))
if (allocated(error)) return
end subroutine test_string_operations_1
subroutine test_string_operations_3(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set
integer :: status
call set%read_bitset(bitstring_0, status)
call check(error, status /= success)
if (allocated(error)) return
call set%read_bitset('s33b' // bitstring_0, status)
call check(error, bits(set), 33)
if (allocated(error)) return
call check(error, set%none())
if (allocated(error)) return
end subroutine test_string_operations_3
subroutine test_string_operations_4(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set
call set%read_bitset('s33b' // bitstring_all )
call check(error, bits(set), 33)
if (allocated(error)) return
call check(error, .not.set%none())
if (allocated(error)) return
call check(error, set%any())
if (allocated(error)) return
call check(error, set%all())
if (allocated(error)) return
end subroutine test_string_operations_4
subroutine test_io(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer :: unit
type(bitset_64) :: set0, set1, set2, set3, set4, set5
call set0%from_string(bitstring_0)
call set1%from_string(bitstring_all)
call set2%from_string(bitstring_33)
open( newunit=unit, status='scratch', form='formatted', &
action='readwrite' )
call set2%write_bitset(unit)
call set1%write_bitset(unit)
call set0%write_bitset(unit)
rewind( unit )
call set3%read_bitset(unit)
call set5%read_bitset(unit)
call set4%read_bitset(unit)
call check(error, set4 == set0 .and. set5 == set1 .and. set3 == set2, &
'transfer to and from units using bitset literals failed.')
if (.not.allocated(error)) then
rewind( unit )
call set2%write_bitset(unit, advance='no')
call set1%write_bitset(unit, advance='no')
call set0%write_bitset(unit)
rewind( unit )
call set3%read_bitset(unit, advance='no')
call set4%read_bitset(unit, advance='no')
call set5%read_bitset(unit)
call check(error, set5 == set0 .and. set4 == set1 .and. set3 == set2, &
'transfer to and from units using bitset literals with advance="no" failed.')
end if
close(unit)
if (allocated(error)) return
open( newunit=unit, form='unformatted', status='scratch', &
action='readwrite' )
call set2%output(unit)
call set1%output(unit)
call set0%output(unit)
rewind( unit )
call set5%input(unit)
call set4%input(unit)
call set3%input(unit)
close( unit )
call check(error, set3 == set0 .and. set4 == set1 .and. set5 == set2, &
'transfer to and from units using output and input failed.')
if (allocated(error)) return
open( newunit=unit, form='unformatted', access='stream', &
status='scratch', action='readwrite' )
call set2%output(unit)
call set1%output(unit)
call set0%output(unit)
rewind( unit )
call set5%input(unit)
call set4%input(unit)
call set3%input(unit)
close( unit )
call check(error, set3 == set0 .and. set4 == set1 .and. set5 == set2, &
'transfer to and from units using stream output and input failed.')
if (allocated(error)) return
end subroutine test_io
subroutine test_initialization(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
logical(int8) :: log1(64) = .true.
logical(int16) :: log2(31) = .false.
logical(int32) :: log3(15) = .true.
logical(int64) :: log4(33) = .false.
logical(int8), allocatable :: log5(:)
logical(int16), allocatable :: log6(:)
logical(int32), allocatable :: log7(:)
logical(int64), allocatable :: log8(:)
type(bitset_64) :: set4, set5
!The following block triggers an issue in gfortran 11 and 12
block
type(bitset_64) :: set6
call check(error, set6 % bits(), 0, &
'set6 % bits() returned non-zero value '//&
'even though set6 was not initialized.')
if (allocated(error)) return
end block
set5 = log1
call check(error, set5%bits(), 64, &
'initialization with logical(int8) failed to set the right size.')
if (allocated(error)) return
call check(error, set5%all(), &
'initialization with logical(int8) failed to set the right values.')
if (allocated(error)) return
set5 = log2
call check(error, set5%bits(), 31, &
'initialization with logical(int16) failed to set the right size.')
if (allocated(error)) return
call check(error, set5%none(), &
'initialization with logical(int16) failed to set the right values.')
if (allocated(error)) return
set5 = log3
call check(error, set5%bits(), 15, &
'initialization with logical(int32) failed to set the right size.')
if (allocated(error)) return
call check(error, set5%all(), &
'initialization with logical(int32) failed to set the right values.')
if (allocated(error)) return
set5 = log4
call check(error, set5%bits(), 33, &
'initialization with logical(int64) failed to set the right size.')
if (allocated(error)) return
call check(error, set5%none(), &
'initialization with logical(int64) failed to set the right values.')
if (allocated(error)) return
set5 = log1
call extract( set4, set5, 1_bits_kind, 33_bits_kind )
call check(error, set4%bits(), 33, &
'initialization with extract failed to set the right size.')
if (allocated(error)) return
call check(error, set4%all(), &
'initialization with extract failed to set the right values.')
if (allocated(error)) return
set4 = set5
call check(error, set4%bits(), 64, &
'initialization with simple assignment failed to set the right size.')
if (allocated(error)) return
call check(error, set4%all(), &
'initialization with simple assignment failed to set the right values.')
if (allocated(error)) return
log5 = set5
call check(error, size(log5), 64, &
'initialization of logical(int8) with assignment failed to set the right size.')
if (allocated(error)) return
call check(error, all(log5) .eqv. .true., & ! FIXME
'initialization of logical(int8) with assignment failed to set the right values.')
if (allocated(error)) return
log6 = set5
call check(error, size(log6), 64, &
'initialization of logical(int16) with assignment failed to set the right size.')
if (allocated(error)) return
call check(error, all(log6) .eqv. .true., & ! FIXME
'initialization of logical(int16) with assignment failed to set the right values.')
if (allocated(error)) return
log7 = set5
call check(error, size(log7), 64, &
'initialization of logical(int32) with assignment failed to set the right size.')
if (allocated(error)) return
call check(error, all(log7), &
'initialization of logical(int32) with assignment failed to set the right values.')
if (allocated(error)) return
log8 = set5
call check(error, size(log8), 64, &
'initialization of logical(int64) with assignment failed to set the right size.')
if (allocated(error)) return
call check(error, merge(.true., .false., all(log8)), & ! FIXME
'initialization of logical(int64) with assignment failed to set the right values.')
if (allocated(error)) return
end subroutine test_initialization
subroutine test_bitset_inquiry(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
integer(bits_kind) :: i
type(bitset_64) :: set0, set1
call set0%from_string(bitstring_0)
call set1%from_string(bitstring_all)
call check(error, set0%none(), 'set0 did not have none set which ' // &
'was unexpected')
if (allocated(error)) return
call check(error, .not. set0%any(), 'set0 had some bits set which ' // &
'was unexpected.')
if (allocated(error)) return
call set0%not()
call check(error, set0%all(), 'set0 did not have all bits set ' // &
'which was unexpected')
if (allocated(error)) return
call check(error, set0%any(), 'set0 had no bits set which ' // &
'was unexpected.')
if (allocated(error)) return
call check(error, set1%any(), 'set1 had no bits set ' // &
'which was unexpected')
if (allocated(error)) return
call check(error, set1%all(), 'set1 did not have all bits set ' // &
'which was unexpected.')
if (allocated(error)) return
call set0%not()
do i=0, set0%bits() - 1
call check(error, .not. set0%test(i), &
'against expectations set0 has at least 1 bit set.')
end do
do i=0, set1%bits() - 1
call check(error, set1%test(i), &
'against expectations set1 has at least 1 bit unset.')
end do
do i=0, set0%bits() - 1
call check(error, .not.( set0%value(i) /= 0), &
'against expectations set0 has at least 1 bit set.')
end do
do i=0, set1%bits() - 1
call check(error, .not.( set1%value(i) /= 1), &
'against expectations set1 has at least 1 bit unset.')
end do
call check(error, set0%bits() == 33, 'et0 unexpectedly does not have 33 bits.')
if (allocated(error)) return
end subroutine test_bitset_inquiry
subroutine test_bit_operations(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set1
call set1%from_string(bitstring_all)
call check(error, set1%all(), 'set1 is not all set.')
if (allocated(error)) return
call set1%clear(0_bits_kind)
call check(error, .not. set1%test(0_bits_kind), 'did not clear the first bit in set1.')
if (allocated(error)) return
call check(error, set1%test(1_bits_kind), 'cleared more than one bit in set1.')
if (allocated(error)) return
call set1%clear(1_bits_kind, 32_bits_kind)
call check(error, set1%none(), 'did not clear remaining bits in set1.')
if (allocated(error)) return
call set1%flip(0_bits_kind)
call check(error, set1%test(0_bits_kind), 'did not flip the first bit in set1.')
if (allocated(error)) return
call check(error, .not. set1%test(1_bits_kind), 'flipped more than one bit in set1.')
if (allocated(error)) return
call set1%flip(1_bits_kind, 32_bits_kind)
call check(error, set1%all(), 'did not flip remaining bits in set1.')
if (allocated(error)) return
call set1%not()
call check(error, set1%none(), 'did not unset bits in set1.')
if (allocated(error)) return
call set1%set(0_bits_kind)
call check(error, set1%test(0_bits_kind), 'did not set the first bit in set1.')
if (allocated(error)) return
call check(error, .not. set1%test(1_bits_kind), 'set more than one bit in set1.')
if (allocated(error)) return
call set1%set(1_bits_kind, 32_bits_kind)
call check(error, set1%all(), 'did not set the remaining bits in set1.')
if (allocated(error)) return
end subroutine test_bit_operations
subroutine test_bitset_comparisons(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set0, set1, set2
call set0%from_string(bitstring_0)
call set1%from_string(bitstring_all)
call set2%from_string(bitstring_33)
call check(error, set0 == set0 .and. set1 == set1 .and. set2 == set2 .and. &
.not. set0 == set1 .and. .not. set0 == set2 .and. .not. &
set1 == set2, 'failed 64 bit equality tests.')
if (allocated(error)) return
call check(error, set0 /= set1 .and. set1 /= set2 .and. set0 /= set2 .and. &
.not. set0 /= set0 .and. .not. set1 /= set1 .and. .not. &
set2 /= set2, 'failed 64 bit inequality tests.')
if (allocated(error)) return
call check(error, set1 > set0 .and. set2 > set0 .and. set1 > set2 .and. &
.not. set0 > set1 .and. .not. set1 > set1 .and. .not. &
set2 > set1, 'failed 64 bit greater than tests.')
if (allocated(error)) return
call check(error, set1 >= set0 .and. set1 >= set2 .and. set2 >= set2 .and. &
.not. set0 >= set1 .and. .not. set0 >= set1 .and. .not. &
set2 >= set1, 'failed 64 bit greater than or equal tests.')
if (allocated(error)) return
call check(error, set0 < set1 .and. set0 < set1 .and. set2 < set1 .and. &
.not. set1 < set0 .and. .not. set0 < set0 .and. .not. &
set1 < set2, 'failed 64 bit less than tests.')
if (allocated(error)) return
call check(error, set0 <= set1 .and. set2 <= set1 .and. set2 <= set2 .and. &
.not. set1 <= set0 .and. .not. set2 <= set0 .and. .not. &
set1 <= set2, 'failed 64 bit less than or equal tests.')
if (allocated(error)) return
end subroutine test_bitset_comparisons
subroutine test_bitset_operations_and(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set3, set4, set0
call set0%from_string( bitstring_all )
call set4%from_string( bitstring_all )
call and( set0, set4 ) ! all all
call check(error, set0%all(), 'first test of AND failed.')
if (allocated(error)) return
call set4%from_string( bitstring_0 )
call set3%from_string( bitstring_all )
call and( set3, set4 ) ! all none
call check(error, set3%none(), 'second test of AND failed.')
if (allocated(error)) return
call set3%from_string( bitstring_all )
call set4%from_string( bitstring_0 )
call and( set4, set3 ) ! none all
call check(error, set4%none(), 'third test of AND failed.')
if (allocated(error)) return
call set3%from_string( bitstring_0 )
call and( set4, set3 ) ! none none
call check(error, set4%none(), 'fourth test of AND failed.')
if (allocated(error)) return
end subroutine test_bitset_operations_and
subroutine test_bitset_operations_nand(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set3, set4
call set3%from_string( bitstring_all )
call set4%from_string( bitstring_all )
call and_not( set4, set3 ) ! all all
call check(error, set4%none(), 'first test of AND_NOT failed.')
if (allocated(error)) return
call set4%from_string( bitstring_0 )
call and_not( set4, set3 ) ! none all
call check(error, set4%none(), 'second test of AND_NOT failed.')
if (allocated(error)) return
call set3%from_string( bitstring_all )
call set4%from_string( bitstring_0 )
call and_not( set3, set4 ) ! all none
call check(error, set3%all(), 'third test of AND_NOT failed.')
if (allocated(error)) return
call set3%from_string( bitstring_0 )
call set4%from_string( bitstring_0 )
call and_not( set3, set4 ) ! none none
call check(error, set3%none(), 'fourth test of AND_NOT failed.')
if (allocated(error)) return
end subroutine test_bitset_operations_nand
subroutine test_bitset_operations_or(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set3, set4
call set3%from_string( bitstring_all )
call set4%from_string( bitstring_all )
call or( set3, set4 ) ! all all
call check(error, set3%all(), 'first test of OR failed.')
if (allocated(error)) return
call set3%from_string( bitstring_0 )
call or( set4, set3 ) ! all none
call check(error, set4%all(), 'second test of OR failed.')
if (allocated(error)) return
call or( set3, set4 ) ! none all
call check(error, set3%all(), 'third test of OR failed.')
if (allocated(error)) return
call set3%from_string( bitstring_0 )
call set4%from_string( bitstring_0 )
call or( set4, set3 ) !none none
call check(error, set4%none(), 'fourth test of OR failed.')
if (allocated(error)) return
end subroutine test_bitset_operations_or
subroutine test_bitset_operations_xor(error)
!> Error handling
type(error_type), allocatable, intent(out) :: error
type(bitset_64) :: set3, set4
call set3%from_string( bitstring_0 )
call set4%from_string( bitstring_0 )
call xor( set3, set4 ) ! none none
call check(error, set3%none(), 'first test of XOR failed.')
if (allocated(error)) return
call set4%from_string( bitstring_all )
call xor( set3, set4 ) ! none all
call check(error, set3%all(), 'second test of XOR failed.')
if (allocated(error)) return
call set4%from_string( bitstring_0 )
call xor( set3, set4 ) ! all none
call check(error, set3%all(), 'third test of XOR failed.')
if (allocated(error)) return
call set4%from_string( bitstring_all )
call xor( set3, set4 ) ! all all
call check(error, set3%none(), 'fourth test of XOR failed.')
if (allocated(error)) return
end subroutine test_bitset_operations_xor
end module test_stdlib_bitset_64
program tester
use, intrinsic :: iso_fortran_env, only : error_unit
use testdrive, only : run_testsuite, new_testsuite, testsuite_type
use test_stdlib_bitset_64, only : collect_stdlib_bitset_64
implicit none
integer :: stat, is
type(testsuite_type), allocatable :: testsuites(:)
character(len=*), parameter :: fmt = '("#", *(1x, a))'
stat = 0
testsuites = [ &
new_testsuite("stdlib-bitset-64", collect_stdlib_bitset_64) &
]
do is = 1, size(testsuites)
write(error_unit, fmt) "Testing:", testsuites(is)%name
call run_testsuite(testsuites(is)%collect, error_unit, stat)
end do
if (stat > 0) then
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
error stop
end if
end program
fortran-lang-stdlib-0ede301/src/ 0000775 0001750 0001750 00000000000 15135654166 016755 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/linalg_core/ 0000775 0001750 0001750 00000000000 15135654166 021233 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/linalg_core/stdlib_linalg_state.fypp 0000664 0001750 0001750 00000013117 15135654166 026145 0 ustar alastair alastair #:include "common.fypp"
#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES
module stdlib_linalg_state
!! Version: experimental
!!
!! Provides a state/error handling derived type for advanced error handling of
!! BLAS/LAPACK based linear algebra procedures. All procedures are pure.
!! ([Specification](../page/specs/stdlib_linalg.html))
use stdlib_linalg_constants,only: ilp
use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp, lk
use stdlib_error, only: state_type, operator(==), operator(/=), operator(<), operator(>), &
operator(<=), operator(>=), STDLIB_SUCCESS, STDLIB_VALUE_ERROR, STDLIB_LINALG_ERROR, STDLIB_INTERNAL_ERROR
use stdlib_io_aux, only: FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_QP, FMT_COMPLEX_SP, FMT_COMPLEX_DP, &
FMT_COMPLEX_QP, FMT_REAL_XDP, FMT_COMPLEX_XDP
implicit none
private
!> Version: experimental
!>
!> A fixed-storage state variable for error handling of linear algebra routines
public :: linalg_state_type
!> Version: experimental
!>
!> Error state handling: if the user requested the error state variable on
!> output, just return it to the user. Otherwise, halt the program on error.
public :: linalg_error_handling
!> Version: experimental
!>
!> Interfaces for comparison operators of error states with integer flags
public :: operator(==),operator(/=)
public :: operator(<),operator(<=)
public :: operator(>),operator(>=)
!> State return types for linear algebra
integer(ilp),parameter,public :: LINALG_SUCCESS = STDLIB_SUCCESS
integer(ilp),parameter,public :: LINALG_VALUE_ERROR = STDLIB_VALUE_ERROR
integer(ilp),parameter,public :: LINALG_ERROR = STDLIB_LINALG_ERROR
integer(ilp),parameter,public :: LINALG_INTERNAL_ERROR = STDLIB_INTERNAL_ERROR
!> `linalg_state_type` defines a state return type for a
!> linear algebra routine. State contains a status flag, a comment, and a
!> procedure specifier that can be used to mark where the error happened
type, extends(state_type) :: linalg_state_type
contains
!> Print error message
procedure :: print_msg => state_message
end type linalg_state_type
interface linalg_state_type
module procedure new_state
module procedure new_state_nowhere
end interface linalg_state_type
contains
!> Interface to print linalg state flags
pure function linalg_message(flag) result(msg)
integer(ilp),intent(in) :: flag
character(len=:),allocatable :: msg
select case (flag)
case (LINALG_SUCCESS); msg = 'Success!'
case (LINALG_VALUE_ERROR); msg = 'Value Error'
case (LINALG_ERROR); msg = 'Algebra Error'
case (LINALG_INTERNAL_ERROR); msg = 'Internal Error'
case default; msg = 'ERROR/INVALID FLAG'
end select
end function linalg_message
!> Flow control: on output flag present, return it; otherwise, halt on error
pure subroutine linalg_error_handling(ierr,ierr_out)
type(linalg_state_type),intent(in) :: ierr
type(linalg_state_type),optional,intent(out) :: ierr_out
character(len=:),allocatable :: err_msg
if (present(ierr_out)) then
! Return error flag
ierr_out = ierr
elseif (ierr%error()) then
err_msg = ierr%print()
error stop err_msg
end if
end subroutine linalg_error_handling
!> Formatted message
pure function state_message(this) result(msg)
class(linalg_state_type),intent(in) :: this
character(len=:),allocatable :: msg
if (this%state == LINALG_SUCCESS) then
msg = 'Success!'
else
msg = linalg_message(this%state)//': '//trim(this%message)
end if
end function state_message
!> Error creation message, with location location
pure type(linalg_state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
!> Location
character(len=*),intent(in) :: where_at
!> Input error flag
integer,intent(in) :: flag
!> Optional rank-agnostic arguments
class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
! Init object
call new_state%parse(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
end function new_state
!> Error creation message, from N input variables (numeric or strings)
pure type(linalg_state_type) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) &
result(new_state)
!> Input error flag
integer,intent(in) :: flag
!> Optional rank-agnostic arguments
class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
! Init object
call new_state%parse(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
end function new_state_nowhere
end module stdlib_linalg_state
fortran-lang-stdlib-0ede301/src/linalg_core/stdlib_linalg_constants.fypp 0000664 0001750 0001750 00000002757 15135654166 027051 0 ustar alastair alastair #:include "common.fypp"
module stdlib_linalg_constants
use stdlib_kinds, only: sp, dp, xdp, qp, int32, int64, lk
use, intrinsic :: ieee_arithmetic, only: ieee_is_nan
!$ use omp_lib
implicit none
public
! Checks whether BLAS is provided by an external library
#ifdef STDLIB_EXTERNAL_BLAS
logical(lk), parameter :: external_blas_ilp32 = .true._lk
#else
logical(lk), parameter :: external_blas_ilp32 = .false._lk
#endif
#ifdef STDLIB_EXTERNAL_BLAS_I64
logical(lk), parameter :: external_blas_ilp64 = .true._lk
#else
logical(lk), parameter :: external_blas_ilp64 = .false._lk
#endif
#ifdef STDLIB_EXTERNAL_LAPACK
logical(lk), parameter :: external_lapack_ilp32 = .true._lk
#else
logical(lk), parameter :: external_lapack_ilp32 = .false._lk
#endif
#ifdef STDLIB_EXTERNAL_LAPACK_I64
logical(lk), parameter :: external_lapack_ilp64 = .true._lk
#else
logical(lk), parameter :: external_lapack_ilp64 = .false._lk
#endif
! Generic checks for external libraries
logical(lk), parameter :: external_blas = external_blas_ilp32 .or. external_blas_ilp64
logical(lk), parameter :: external_lapack = external_lapack_ilp32 .or. external_lapack_ilp64
! Support both 32-bit (ilp) and 64-bit (ilp64) integer kinds
integer, parameter :: ilp = int32
integer, parameter :: ilp64 = #{if WITH_ILP64}# int64 #{else}# -1 #{endif}#
private :: int32, int64
end module stdlib_linalg_constants
fortran-lang-stdlib-0ede301/src/linalg_core/CMakeLists.txt 0000664 0001750 0001750 00000000542 15135654166 023774 0 ustar alastair alastair set(linalg_core_fppFiles
stdlib_linalg_state.fypp
)
set(linalg_core_cppFiles
stdlib_linalg_constants.fypp
)
set(linalg_core_f90Files
)
configure_stdlib_target(${PROJECT_NAME}_linalg_core linalg_core_f90Files linalg_core_fppFiles linalg_core_cppFiles)
target_link_libraries(${PROJECT_NAME}_linalg_core PUBLIC ${PROJECT_NAME}_core)
fortran-lang-stdlib-0ede301/src/stdlib_version.fypp 0000664 0001750 0001750 00000003541 15135654166 022706 0 ustar alastair alastair ! SPDX-Identifier: MIT
#:include "common.fypp"
!> Version information on stdlib
module stdlib_version
implicit none
private
public :: get_stdlib_version
public :: stdlib_version_string, stdlib_version_compact
!> String representation of the standard library version
character(len=*), parameter :: stdlib_version_string = "${PROJECT_VERSION}$"
!> Major version number of the above standard library version
integer, parameter :: stdlib_major = ${PROJECT_VERSION_MAJOR}$
!> Minor version number of the above standard library version
integer, parameter :: stdlib_minor = ${PROJECT_VERSION_MINOR}$
!> Patch version number of the above standard library version
integer, parameter :: stdlib_patch = ${PROJECT_VERSION_PATCH}$
!> Compact numeric representation of the standard library version
integer, parameter :: stdlib_version_compact = &
& stdlib_major*10000 + stdlib_minor*100 + stdlib_patch
contains
!> Getter function to retrieve standard library version
pure subroutine get_stdlib_version(major, minor, patch, string)
!> Major version number of the standard library version
integer, intent(out), optional :: major
!> Minor version number of the standard library version
integer, intent(out), optional :: minor
!> Patch version number of the standard library version
integer, intent(out), optional :: patch
!> String representation of the standard library version
character(len=:), allocatable, intent(out), optional :: string
if (present(major)) then
major = stdlib_major
end if
if (present(minor)) then
minor = stdlib_minor
end if
if (present(patch)) then
patch = stdlib_patch
end if
if (present(string)) then
string = stdlib_version_string
end if
end subroutine get_stdlib_version
end module stdlib_version
fortran-lang-stdlib-0ede301/src/lapack_extended/ 0000775 0001750 0001750 00000000000 15135654166 022070 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/lapack_extended/stdlib_lapack_extended.fypp 0000664 0001750 0001750 00000006731 15135654166 027453 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES
submodule(stdlib_lapack_extended_base) stdlib_lapack_extended
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#:for k1,t1,s1 in KINDS_TYPES
pure module subroutine stdlib${ii}$_glagtm_${s1}$(trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
character, intent(in) :: trans
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
${t1}$, intent(in) :: alpha, beta
${t1}$, intent(inout) :: b(ldb,*)
${t1}$, intent(in) :: d(*), dl(*), du(*), x(ldx,*)
! Internal variables.
integer(${ik}$) :: i, j
${t1}$ :: temp
if(n == 0) then
return
endif
if(beta == 0.0_${k1}$) then
b(1:n, 1:nrhs) = 0.0_${k1}$
else
b(1:n, 1:nrhs) = beta * b(1:n, 1:nrhs)
end if
if(trans == 'N') then
do j = 1, nrhs
if(n == 1_${ik}$) then
temp = d(1_${ik}$) * x(1_${ik}$, j)
b(1_${ik}$, j) = b(1_${ik}$, j) + alpha * temp
else
temp = d(1_${ik}$) * x(1_${ik}$, j) + du(1_${ik}$) * x(2_${ik}$, j)
b(1_${ik}$, j) = b(1_${ik}$, j) + alpha * temp
do i = 2, n - 1
temp = dl(i - 1) * x(i - 1, j) + d(i) * x(i, j) + du(i) * x(i + 1, j)
b(i, j) = b(i, j) + alpha * temp
end do
temp = dl(n - 1) * x(n - 1, j) + d(n) * x(n, j)
b(n, j) = b(n, j) + alpha * temp
end if
end do
#:if t1.startswith('complex')
else if(trans == 'C') then
do j = 1, nrhs
if(n == 1_${ik}$) then
temp = conjg(d(1_${ik}$)) * x(1_${ik}$, j)
b(1_${ik}$, j) = b(1_${ik}$, j) + alpha * temp
else
temp = conjg(d(1_${ik}$)) * x(1_${ik}$, j) + conjg(dl(1_${ik}$)) * x(2_${ik}$, j)
b(1_${ik}$, j) = b(1_${ik}$, j) + alpha * temp
do i = 2, n - 1
temp = conjg(du(i - 1)) * x(i - 1, j) + conjg(d(i)) * x(i, j) + conjg(dl(i)) * x(i + 1, j)
b(i, j) = b(i, j) + alpha * temp
end do
temp = conjg(du(n - 1)) * x(n - 1, j) + conjg(d(n)) * x(n, j)
b(n, j) = b(n, j) + alpha * temp
end if
end do
#:endif
else
do j = 1, nrhs
if(n == 1_${ik}$) then
temp = d(1_${ik}$) * x(1_${ik}$, j)
b(1_${ik}$, j) = b(1_${ik}$, j) + alpha * temp
else
temp = d(1_${ik}$) * x(1_${ik}$, j) + dl(1_${ik}$) * x(2_${ik}$, j)
b(1_${ik}$, j) = b(1_${ik}$, j) + alpha * temp
do i = 2, n - 1
temp = du(i - 1) * x(i - 1, j) + d(i) * x(i, j) + dl(i) * x(i + 1, j)
b(i, j) = b(i, j) + alpha * temp
end do
temp = du(n - 1) * x(n - 1, j) + d(n) * x(n, j)
b(n, j) = b(n, j) + alpha * temp
end if
end do
end if
end subroutine stdlib${ii}$_glagtm_${s1}$
#:endfor
#:endfor
end submodule fortran-lang-stdlib-0ede301/src/lapack_extended/CMakeLists.txt 0000664 0001750 0001750 00000000542 15135654166 024631 0 ustar alastair alastair set(lapack_extended_fppFiles
stdlib_lapack_extended_base.fypp
stdlib_lapack_extended.fypp
)
set(lapack_extended_cppFiles
)
configure_stdlib_target(${PROJECT_NAME}_lapack_extended "" lapack_extended_fppFiles lapack_extended_cppFiles)
target_link_libraries(${PROJECT_NAME}_lapack_extended PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_linalg_core)
fortran-lang-stdlib-0ede301/src/lapack_extended/stdlib_lapack_extended_base.fypp 0000664 0001750 0001750 00000001554 15135654166 030443 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES
module stdlib_lapack_extended_base
use stdlib_linalg_constants
implicit none
interface glagtm
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#:for k1,t1,s1 in KINDS_TYPES
pure module subroutine stdlib${ii}$_glagtm_${s1}$(trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
character, intent(in) :: trans
integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs
${t1}$, intent(in) :: alpha, beta
${t1}$, intent(inout) :: b(ldb,*)
${t1}$, intent(in) :: d(*), dl(*), du(*), x(ldx,*)
end subroutine stdlib${ii}$_glagtm_${s1}$
#:endfor
#:endfor
end interface
end module fortran-lang-stdlib-0ede301/src/stringlist/ 0000775 0001750 0001750 00000000000 15135654166 021157 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/stringlist/stdlib_stringlist_type.f90 0000664 0001750 0001750 00000066430 15135654166 026314 0 ustar alastair alastair ! stdlib_stringlist_type.f90 --
! Module for storing and manipulating list of strings
! The strings may have arbitrary lengths, not necessarily the same
!
! insert AT: Inserts an element BEFORE the element present currently at the asked index
! for forward indexes
! Inserts an element AFTER the element present currently at the asked index
! for backward indexes
! In other words, after insertion the element will be present at the asked index
! for both forward and backward indexes
! insert BEFORE: Inserts an element BEFORE the element present currently at the asked index
! insert AFTER: Inserts an element AFTER the element present currently at the asked index
!
! Note the distinction between AT and BEFORE in the module. Care has been taken to keep it consistent
! throughout the PR
!
module stdlib_stringlist_type
use stdlib_string_type, only: string_type, operator(/=)
use stdlib_math, only: clip
implicit none
private
public :: stringlist_type, operator(//), operator(==), operator(/=)
public :: list_head, list_tail, fidx, bidx, stringlist_index_type
type stringlist_index_type
private
logical :: forward
integer :: offset
end type stringlist_index_type
type(stringlist_index_type), parameter :: list_head = stringlist_index_type( .true. , 1 ) ! fidx(1)
type(stringlist_index_type), parameter :: list_tail = stringlist_index_type( .false., 1 ) ! bidx(1)
!> Version: experimental
!>
!> Returns an instance of type 'stringlist_index_type' representing forward index
!> [Specifications](../page/specs/stdlib_stringlist_type.html#fidx)
interface fidx
module procedure forward_index
end interface
!> Version: experimental
!>
!> Returns an instance of type 'stringlist_index_type' representing backward index
!> [Specifications](../page/specs/stdlib_stringlist_type.html#bidx)
interface bidx
module procedure backward_index
end interface
type stringlist_type
private
type(string_type), dimension(:), allocatable :: stringarray
contains
private
procedure, public :: clear => clear_list
procedure, public :: len => length_list
procedure :: to_future_at_idxn => convert_to_future_at_idxn
procedure :: to_current_idxn => convert_to_current_idxn
procedure :: insert_at_char_idx => insert_at_char_idx_wrap
procedure :: insert_at_string_idx => insert_at_string_idx_wrap
procedure :: insert_at_stringlist_idx => insert_at_stringlist_idx_wrap
procedure :: insert_at_chararray_idx => insert_at_chararray_idx_wrap
procedure :: insert_at_stringarray_idx => insert_at_stringarray_idx_wrap
generic, public :: insert_at => insert_at_char_idx, &
insert_at_string_idx, &
insert_at_stringlist_idx, &
insert_at_chararray_idx, &
insert_at_stringarray_idx
procedure :: insert_before_string_int => insert_before_string_int_impl
procedure :: insert_before_stringlist_int => insert_before_stringlist_int_impl
procedure :: insert_before_chararray_int => insert_before_chararray_int_impl
procedure :: insert_before_stringarray_int => insert_before_stringarray_int_impl
generic :: insert_before => insert_before_string_int, &
insert_before_stringlist_int, &
insert_before_chararray_int, &
insert_before_stringarray_int
procedure :: get_string_idx => get_string_idx_wrap
generic, public :: get => get_string_idx
end type stringlist_type
!> Version: experimental
!>
!> Constructor for stringlist
!> Returns an instance of type stringlist_type
!> [Specifications](../page/specs/stdlib_stringlist_type.html#stringlist_type)
interface stringlist_type
module procedure new_stringlist
module procedure new_stringlist_carray
module procedure new_stringlist_sarray
end interface
!> Version: experimental
!>
!> Concatenates stringlist with the input entity
!> Returns a new stringlist
!> [Specifications](../page/specs/stdlib_stringlist_type.html#append-operator)
interface operator(//)
module procedure append_char
module procedure append_string
module procedure prepend_char
module procedure prepend_string
module procedure append_stringlist
module procedure append_carray
module procedure append_sarray
module procedure prepend_carray
module procedure prepend_sarray
end interface
!> Version: experimental
!>
!> Compares stringlist for equality with the input entity
!> Returns a logical
!> [Specifications](../page/specs/stdlib_stringlist_type.html#equality-operator)
interface operator(==)
module procedure eq_stringlist
module procedure eq_stringlist_carray
module procedure eq_stringlist_sarray
module procedure eq_carray_stringlist
module procedure eq_sarray_stringlist
end interface
!> Version: experimental
!>
!> Compares stringlist for inequality with the input entity
!> Returns a logical
!> [Specifications](../page/specs/stdlib_stringlist_type.html#inequality-operator)
interface operator(/=)
module procedure ineq_stringlist
module procedure ineq_stringlist_carray
module procedure ineq_stringlist_sarray
module procedure ineq_carray_stringlist
module procedure ineq_sarray_stringlist
end interface
contains
! constructor for stringlist_type:
!> Constructor with no argument
!> Returns a new instance of type stringlist
pure function new_stringlist()
type(stringlist_type) :: new_stringlist
end function new_stringlist
!> Constructor to convert chararray to stringlist
!> Returns a new instance of type stringlist
pure function new_stringlist_carray( array )
character(len=*), dimension(:), intent(in) :: array
type(stringlist_type) :: new_stringlist_carray
type(string_type), dimension( size(array) ) :: sarray
integer :: i
do i = 1, size(array)
sarray(i) = string_type( array(i) )
end do
new_stringlist_carray = stringlist_type( sarray )
end function new_stringlist_carray
!> Constructor to convert stringarray to stringlist
!> Returns a new instance of type stringlist
pure function new_stringlist_sarray( array )
type(string_type), dimension(:), intent(in) :: array
type(stringlist_type) :: new_stringlist_sarray
new_stringlist_sarray = stringlist_type()
new_stringlist_sarray%stringarray = array
end function new_stringlist_sarray
! constructor for stringlist_index_type:
!> Returns an instance of type 'stringlist_index_type' representing forward index 'idx'
pure function forward_index( idx )
integer, intent(in) :: idx
type(stringlist_index_type) :: forward_index
forward_index = stringlist_index_type( .true., idx )
end function forward_index
!> Returns an instance of type 'stringlist_index_type' representing backward index 'idx'
pure function backward_index( idx )
integer, intent(in) :: idx
type(stringlist_index_type) :: backward_index
backward_index = stringlist_index_type( .false., idx )
end function backward_index
! concatenation operator:
!> Appends character scalar 'rhs' to the stringlist 'list'
!> Returns a new stringlist
function append_char( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
character(len=*), intent(in) :: rhs
type(stringlist_type) :: append_char
append_char = lhs // string_type( rhs )
end function append_char
!> Appends string 'rhs' to the stringlist 'list'
!> Returns a new stringlist
function append_string( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
type(string_type), intent(in) :: rhs
type(stringlist_type) :: append_string
append_string = lhs ! Intent: creating a full, deep copy
call append_string%insert_at( list_tail, rhs )
end function append_string
!> Prepends character scalar 'lhs' to the stringlist 'rhs'
!> Returns a new stringlist
function prepend_char( lhs, rhs )
character(len=*), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
type(stringlist_type) :: prepend_char
prepend_char = string_type( lhs ) // rhs
end function prepend_char
!> Prepends string 'lhs' to the stringlist 'rhs'
!> Returns a new stringlist
function prepend_string( lhs, rhs )
type(string_type), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
type(stringlist_type) :: prepend_string
prepend_string = rhs ! Intent: creating a full, deep copy
call prepend_string%insert_at( list_head, lhs )
end function prepend_string
!> Appends stringlist 'rhs' to the stringlist 'lhs'
!> Returns a new stringlist
function append_stringlist( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
type(stringlist_type) :: append_stringlist
append_stringlist = lhs ! Intent: creating a full, deep copy
call append_stringlist%insert_at( list_tail, rhs )
end function append_stringlist
!> Appends chararray 'rhs' to the stringlist 'lhs'
!> Returns a new stringlist
function append_carray( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
character(len=*), dimension(:), intent(in) :: rhs
type(stringlist_type) :: append_carray
append_carray = lhs ! Intent: creating a full, deep copy
call append_carray%insert_at( list_tail, rhs )
end function append_carray
!> Appends stringarray 'rhs' to the stringlist 'lhs'
!> Returns a new stringlist
function append_sarray( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
type(string_type), dimension(:), intent(in) :: rhs
type(stringlist_type) :: append_sarray
append_sarray = lhs ! Intent: creating a full, deep copy
call append_sarray%insert_at( list_tail, rhs )
end function append_sarray
!> Prepends chararray 'lhs' to the stringlist 'rhs'
!> Returns a new stringlist
function prepend_carray( lhs, rhs )
character(len=*), dimension(:), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
type(stringlist_type) :: prepend_carray
prepend_carray = rhs ! Intent: creating a full, deep copy
call prepend_carray%insert_at( list_head, lhs )
end function prepend_carray
!> Prepends stringarray 'lhs' to the stringlist 'rhs'
!> Returns a new stringlist
function prepend_sarray( lhs, rhs )
type(string_type), dimension(:), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
type(stringlist_type) :: prepend_sarray
prepend_sarray = rhs ! Intent: creating a full, deep copy
call prepend_sarray%insert_at( list_head, lhs )
end function prepend_sarray
! equality operator:
!> Compares stringlist 'lhs' for equality with stringlist 'rhs'
!> Returns a logical
pure logical function eq_stringlist( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
integer :: i
eq_stringlist = .false.
if ( lhs%len() == rhs%len() ) then
eq_stringlist = .true.
do i = 1, lhs%len()
if ( lhs%stringarray(i) /= rhs%stringarray(i) ) then
eq_stringlist = .false.
exit
end if
end do
end if
end function eq_stringlist
!> Compares stringlist 'lhs' for equality with chararray 'rhs'
!> Returns a logical
pure logical function eq_stringlist_carray( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
character(len=*), dimension(:), intent(in) :: rhs
integer :: i
eq_stringlist_carray = .false.
if ( lhs%len() == size( rhs ) ) then
eq_stringlist_carray = .true.
do i = 1, lhs%len()
if ( lhs%stringarray(i) /= rhs(i) ) then
eq_stringlist_carray = .false.
exit
end if
end do
end if
end function eq_stringlist_carray
!> Compares stringlist 'lhs' for equality with stringarray 'rhs'
!> Returns a logical
pure logical function eq_stringlist_sarray( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
type(string_type), dimension(:), intent(in) :: rhs
integer :: i
eq_stringlist_sarray = .false.
if ( lhs%len() == size( rhs ) ) then
eq_stringlist_sarray = .true.
do i = 1, lhs%len()
if ( lhs%stringarray(i) /= rhs(i) ) then
eq_stringlist_sarray = .false.
exit
end if
end do
end if
end function eq_stringlist_sarray
!> Compares chararray 'lhs' for equality with stringlist 'rhs'
!> Returns a logical
pure logical function eq_carray_stringlist( lhs, rhs )
character(len=*), dimension(:), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
eq_carray_stringlist = ( rhs == lhs )
end function eq_carray_stringlist
!> Compares stringarray 'lhs' for equality with stringlist 'rhs'
!> Returns a logical
pure logical function eq_sarray_stringlist( lhs, rhs )
type(string_type), dimension(:), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
eq_sarray_stringlist = ( rhs == lhs )
end function eq_sarray_stringlist
! inequality operator:
!> Compares stringlist 'lhs' for inequality with stringlist 'rhs'
!> Returns a logical
pure logical function ineq_stringlist( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
ineq_stringlist = .not.( lhs == rhs )
end function ineq_stringlist
!> Compares stringlist 'lhs' for inequality with chararray 'rhs'
!> Returns a logical
pure logical function ineq_stringlist_carray( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
character(len=*), dimension(:), intent(in) :: rhs
ineq_stringlist_carray = .not.( lhs == rhs )
end function ineq_stringlist_carray
!> Compares stringlist 'lhs' for inequality with stringarray 'rhs'
!> Returns a logical
pure logical function ineq_stringlist_sarray( lhs, rhs )
type(stringlist_type), intent(in) :: lhs
type(string_type), dimension(:), intent(in) :: rhs
ineq_stringlist_sarray = .not.( lhs == rhs )
end function ineq_stringlist_sarray
!> Compares chararray 'lhs' for inequality with stringlist 'rhs'
!> Returns a logical
pure logical function ineq_carray_stringlist( lhs, rhs )
character(len=*), dimension(:), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
ineq_carray_stringlist = .not.( lhs == rhs)
end function ineq_carray_stringlist
!> Compares stringarray 'lhs' for inequality with stringlist 'rhs'
!> Returns a logical
pure logical function ineq_sarray_stringlist( lhs, rhs )
type(string_type), dimension(:), intent(in) :: lhs
type(stringlist_type), intent(in) :: rhs
ineq_sarray_stringlist = .not.( lhs == rhs )
end function ineq_sarray_stringlist
! clear:
!> Version: experimental
!>
!> Resets stringlist 'list' to an empy stringlist of len 0
!> Modifies the input stringlist 'list'
subroutine clear_list( list )
class(stringlist_type), intent(inout) :: list
if ( allocated( list%stringarray ) ) then
deallocate( list%stringarray )
end if
end subroutine clear_list
! len:
!> Version: experimental
!>
!> Returns the len (length) of the list
!> Returns an integer
pure integer function length_list( list )
class(stringlist_type), intent(in) :: list
length_list = 0
if ( allocated( list%stringarray ) ) then
length_list = size( list%stringarray )
end if
end function length_list
! to_future_at_idxn:
!> Version: experimental
!>
!> Converts a forward index OR a backward index to an integer index at
!> which the new element will be present post insertion (i.e. in future)
!> Returns an integer
pure integer function convert_to_future_at_idxn( list, idx )
!> Not a part of public API
class(stringlist_type), intent(in) :: list
type(stringlist_index_type), intent(in) :: idx
! Formula: merge( fidx( x ) - ( list_head - 1 ), len - bidx( x ) + ( list_tail - 1 ) + 2, ... )
convert_to_future_at_idxn = merge( idx%offset, list%len() - idx%offset + 2 , idx%forward )
end function convert_to_future_at_idxn
! to_current_idxn:
!> Version: experimental
!>
!> Converts a forward index OR backward index to its equivalent integer index idxn
!> Returns an integer
pure integer function convert_to_current_idxn( list, idx )
!> Not a part of public API
class(stringlist_type), intent(in) :: list
type(stringlist_index_type), intent(in) :: idx
! Formula: merge( fidx( x ) - ( list_head - 1 ), len + 1 - bidx( x ) + ( list_tail - 1 ), ... )
convert_to_current_idxn = merge( idx%offset, list%len() - idx%offset + 1, idx%forward )
end function convert_to_current_idxn
! insert_at:
!> Version: experimental
!>
!> Inserts character scalar 'string' AT stringlist_index 'idx' in stringlist 'list'
!> Modifies the input stringlist 'list'
subroutine insert_at_char_idx_wrap( list, idx, string )
class(stringlist_type), intent(inout) :: list
type(stringlist_index_type), intent(in) :: idx
character(len=*), intent(in) :: string
call list%insert_at( idx, string_type( string ) )
end subroutine insert_at_char_idx_wrap
!> Version: experimental
!>
!> Inserts string 'string' AT stringlist_index 'idx' in stringlist 'list'
!> Modifies the input stringlist 'list'
subroutine insert_at_string_idx_wrap( list, idx, string )
class(stringlist_type), intent(inout) :: list
type(stringlist_index_type), intent(in) :: idx
type(string_type), intent(in) :: string
call list%insert_before( list%to_future_at_idxn( idx ), string )
end subroutine insert_at_string_idx_wrap
!> Version: experimental
!>
!> Inserts stringlist 'slist' AT stringlist_index 'idx' in stringlist 'list'
!> Modifies the input stringlist 'list'
subroutine insert_at_stringlist_idx_wrap( list, idx, slist )
class(stringlist_type), intent(inout) :: list
type(stringlist_index_type), intent(in) :: idx
type(stringlist_type), intent(in) :: slist
call list%insert_before( list%to_future_at_idxn( idx ), slist )
end subroutine insert_at_stringlist_idx_wrap
!> Version: experimental
!>
!> Inserts chararray 'carray' AT stringlist_index 'idx' in stringlist 'list'
!> Modifies the input stringlist 'list'
subroutine insert_at_chararray_idx_wrap( list, idx, carray )
class(stringlist_type), intent(inout) :: list
type(stringlist_index_type), intent(in) :: idx
character(len=*), dimension(:), intent(in) :: carray
call list%insert_before( list%to_future_at_idxn( idx ), carray )
end subroutine insert_at_chararray_idx_wrap
!> Version: experimental
!>
!> Inserts stringarray 'sarray' AT stringlist_index 'idx' in stringlist 'list'
!> Modifies the input stringlist 'list'
subroutine insert_at_stringarray_idx_wrap( list, idx, sarray )
class(stringlist_type), intent(inout) :: list
type(stringlist_index_type), intent(in) :: idx
type(string_type), dimension(:), intent(in) :: sarray
call list%insert_before( list%to_future_at_idxn( idx ), sarray )
end subroutine insert_at_stringarray_idx_wrap
!> Version: experimental
!>
!> Inserts 'positions' number of empty positions BEFORE integer index 'idxn'
!> Modifies the input stringlist 'list'
subroutine insert_before_empty_positions( list, idxn, positions )
!> Not a part of public API
class(stringlist_type), intent(inout) :: list
integer, intent(inout) :: idxn
integer, intent(in) :: positions
integer :: i, inew
integer :: new_len, old_len
type(string_type), dimension(:), allocatable :: new_stringarray
if (positions > 0) then
idxn = clip( idxn, 1, list%len() + 1 )
old_len = list%len()
new_len = old_len + positions
allocate( new_stringarray(new_len) )
do i = 1, idxn - 1
! TODO: can be improved by move
new_stringarray(i) = list%stringarray(i)
end do
do i = idxn, old_len
inew = i + positions
! TODO: can be improved by move
new_stringarray(inew) = list%stringarray(i)
end do
call move_alloc( new_stringarray, list%stringarray )
end if
end subroutine insert_before_empty_positions
!> Version: experimental
!>
!> Inserts string 'string' BEFORE integer index 'idxn' in the underlying stringarray
!> Modifies the input stringlist 'list'
subroutine insert_before_string_int_impl( list, idxn, string )
!> Not a part of public API
class(stringlist_type), intent(inout) :: list
integer, intent(in) :: idxn
type(string_type), intent(in) :: string
integer :: work_idxn
work_idxn = idxn
call insert_before_empty_positions( list, work_idxn, 1 )
list%stringarray(work_idxn) = string
end subroutine insert_before_string_int_impl
!> Version: experimental
!>
!> Inserts stringlist 'slist' BEFORE integer index 'idxn' in the underlying stringarray
!> Modifies the input stringlist 'list'
subroutine insert_before_stringlist_int_impl( list, idxn, slist )
!> Not a part of public API
class(stringlist_type), intent(inout) :: list
integer, intent(in) :: idxn
type(stringlist_type), intent(in) :: slist
integer :: i
integer :: work_idxn, idxnew
integer :: pre_length, post_length
work_idxn = idxn
pre_length = slist%len()
call insert_before_empty_positions( list, work_idxn, pre_length )
post_length = slist%len()
do i = 1, min( work_idxn - 1, pre_length )
idxnew = work_idxn + i - 1
list%stringarray(idxnew) = slist%stringarray(i)
end do
do i = work_idxn + post_length - pre_length, post_length
idxnew = work_idxn + i - post_length + pre_length - 1
list%stringarray(idxnew) = slist%stringarray(i)
end do
end subroutine insert_before_stringlist_int_impl
!> Version: experimental
!>
!> Inserts chararray 'carray' BEFORE integer index 'idxn' in the underlying stringarray
!> Modifies the input stringlist 'list'
subroutine insert_before_chararray_int_impl( list, idxn, carray )
!> Not a part of public API
class(stringlist_type), intent(inout) :: list
integer, intent(in) :: idxn
character(len=*), dimension(:), intent(in) :: carray
integer :: i
integer :: work_idxn, idxnew
work_idxn = idxn
call insert_before_empty_positions( list, work_idxn, size( carray ) )
do i = 1, size( carray )
idxnew = work_idxn + i - 1
list%stringarray(idxnew) = string_type( carray(i) )
end do
end subroutine insert_before_chararray_int_impl
!> Version: experimental
!>
!> Inserts stringarray 'sarray' BEFORE integer index 'idxn' in the underlying stringarray
!> Modifies the input stringlist 'list'
subroutine insert_before_stringarray_int_impl( list, idxn, sarray )
!> Not a part of public API
class(stringlist_type), intent(inout) :: list
integer, intent(in) :: idxn
type(string_type), dimension(:), intent(in) :: sarray
integer :: i
integer :: work_idxn, idxnew
work_idxn = idxn
call insert_before_empty_positions( list, work_idxn, size( sarray ) )
do i = 1, size( sarray )
idxnew = work_idxn + i - 1
list%stringarray(idxnew) = sarray(i)
end do
end subroutine insert_before_stringarray_int_impl
! get:
!> Version: experimental
!>
!> Returns the string present at stringlist_index 'idx' in stringlist 'list'
!> Returns string_type instance
pure function get_string_idx_wrap( list, idx )
class(stringlist_type), intent(in) :: list
type(stringlist_index_type), intent(in) :: idx
type(string_type) :: get_string_idx_wrap
integer :: idxn
idxn = list%to_current_idxn( idx )
! if the index is out of bounds, return a string_type equivalent to empty string
if ( 1 <= idxn .and. idxn <= list%len() ) then
get_string_idx_wrap = list%stringarray(idxn)
end if
end function get_string_idx_wrap
end module stdlib_stringlist_type
fortran-lang-stdlib-0ede301/src/stringlist/CMakeLists.txt 0000664 0001750 0001750 00000000523 15135654166 023717 0 ustar alastair alastair set(stringlist_fppFiles
)
set(stringlist_cppFiles
)
set(stringlist_f90Files
stdlib_stringlist_type.f90
)
configure_stdlib_target(${PROJECT_NAME}_stringlist stringlist_f90Files stringlist_fppFiles stringlist_cppFiles)
target_link_libraries(${PROJECT_NAME}_stringlist PUBLIC ${PROJECT_NAME}_math ${PROJECT_NAME}_strings)
fortran-lang-stdlib-0ede301/src/logger/ 0000775 0001750 0001750 00000000000 15135654166 020234 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/logger/CMakeLists.txt 0000664 0001750 0001750 00000000422 15135654166 022772 0 ustar alastair alastair set(logger_fppFiles
)
set(logger_cppFiles
)
set(logger_f90Files
stdlib_logger.f90
)
configure_stdlib_target(${PROJECT_NAME}_logger logger_f90Files logger_fppFiles logger_cppFiles)
target_link_libraries(${PROJECT_NAME}_logger PUBLIC ${PROJECT_NAME}_core)
fortran-lang-stdlib-0ede301/src/logger/stdlib_logger.f90 0000664 0001750 0001750 00000165071 15135654166 023406 0 ustar alastair alastair module stdlib_logger
!!### Module stdlib_logger
!!
!! This module defines a derived type, procedures, a variable, and
!! constants to be used for logging information and reporting errors
!! in Fortran applications.
!!([Specification](../page/specs/stdlib_logger.html))
!! The derived type, `logger_type`, is to be used to define variables to
!! serve as both local and global loggers. A logger directs its messages
!! to selected I/O units so the user has a record (a log) of major events.
!! For each entity of `logger_type` the reports go to a list of I/O units
!! represented by the private internal array, `log_units`. If `log_units` is
!! empty then output by default goes to `output_unit`. Otherwise reports
!! go to `output_unit` only if it has been explicitly added to `log_units`.
!! Each entity of type `logger_type` also maintains an internal state
!! controlling the formatting of output.
!!
!! The procedures are as follows. The logical function
!! `log_units_assigned` returns the number of I/O units in `log_units`. The
!! subroutines `add_log_file` and `add_log_unit` include the specified file
!! in `log_units`. `remove_log_units` removes the specified logical unit from
!! the `log_units` array and optionally closes the file. `configure`
!! configures the details of the logging process. `configuration`
!! reports the details of that configuration. The subroutines
!! `log_error`, `log_information`, `log_io_error`, `log_message`,
!! `log_text_error`, and `log_warning` send messages to the log units.
!!
!! The variable `global_logger` of type `logger_type` can be used
!! as a default global logger anywhere in the source code.
!!
!! The constants are used to report errors by some of the subroutines
!! in their optional `stat` arguments. The constants are as follows.
!! `success` indicates that no error has occurred. `close_failure`
!! indicates that a `close` statement for an I/O unit failed.
!! `index_invalid_error` indicates that `column` was invalid for
!! the given `line`. `open_failure` indicates that an `open` statement
!! failed. `read_only_error` indicates that an output unit did not have a
!! `"write"` or `"readwrite"` action. `non_sequential_error` indicates
!! that the unit did not have `sequential` access. `unformatted_in_error`
!! indicates that the unit did not have a `form` of `"formatted"`.
!! `unopened_in_error` indicates that the unit was not opened. `write_failure`
!! indicates that at least one of the writes to `log_units` failed.
use, intrinsic :: &
iso_fortran_env, only : &
error_unit, &
input_unit, &
output_unit
use stdlib_ascii, only : to_lower
use stdlib_optval, only : optval
implicit none
private
public :: global_logger, logger_type
!! public constants used as error flags
integer, parameter, public :: &
success = 0, &
close_failure = 1, &
index_invalid_error = 2, &
non_sequential_error = 3, &
open_failure = 4, &
read_only_error = 5, &
unformatted_in_error = 6, &
unopened_in_error = 7, &
write_failure = 8
integer, parameter, public :: &
debug_level = 10, &
information_level = 20, &
warning_level = 30, &
error_level = 40, &
io_error_level = 40, &
text_error_level = 50, &
all_level = -10 + min( &
debug_level, &
information_level, &
warning_level, &
error_level, &
io_error_level, &
text_error_level), &
none_level = 10 + max( &
debug_level, &
information_level, &
warning_level, &
error_level, &
io_error_level, &
text_error_level)
character(*), parameter :: module_name = 'stdlib_logger'
type :: logger_type
!! version: experimental
!! Public derived type ([Specification](../page/specs/stdlib_logger.html#the-derived-type-logger_type))
private
logical :: add_blank_line = .false.
logical :: indent_lines = .true.
integer :: level = information_level
integer, allocatable :: log_units(:)
integer :: max_width = 0
logical :: time_stamp = .true.
integer :: units = 0
contains
private
procedure, public, pass(self) :: add_log_file
procedure, public, pass(self) :: add_log_unit
procedure, public, pass(self) :: configuration
procedure, public, pass(self) :: configure
procedure, public, pass(self) :: log_debug
procedure, public, pass(self) :: log_error
procedure, public, pass(self) :: log_information
procedure, public, pass(self) :: log_io_error
procedure, public, pass(self) :: log_message
procedure, public, pass(self) :: log_text_error
procedure, public, pass(self) :: log_units_assigned
procedure, public, pass(self) :: log_warning
procedure, public, pass(self) :: remove_log_unit
final :: final_logger
end type logger_type
!! Variable of type `logger_type` to be used as a global logger
type(logger_type) :: global_logger
character(*), parameter :: &
invalid_column = 'column is not a valid index to line.'
contains
subroutine add_log_file( self, filename, unit, action, position, status, &
stat )
!! version: experimental
!! Opens a formatted sequential access output file, `filename` using
!! `newunit` and adds the resulting unit number to `self`'s `log_units`
!! array. `action`, if present, is the `action` specifier of the `open`
!! statement, and has the default value of `"write"`. `position`, if present,
!! is the `position` specifier, and has the default value of `"REWIND"`.
!! `status`, if present, is the `status` specifier of the `open` statement,
!! and has the default value of `"REPLACE"`. `stat`, if present, has the value
!! `success` if `filename` could be opened, `read_only_error` if `action` is
!! `"read"`, and `open_failure` otherwise.
!!([Specification](../page/specs/stdlib_logger.html#add_log_file-open-a-file-and-add-its-unit-to-self-log_units))
class(logger_type), intent(inout) :: self
!! The logger variable to which the file is to be added
character(*), intent(in) :: filename
!! The name of the file to be added to the logger
integer, intent(out), optional :: unit
!! The resulting I/O unit number
character(*), intent(in), optional :: action
!! The `action` specifier for the `open`` statement
character(*), intent(in), optional :: position
!! The `position` specifier for the `open` statement
character(*), intent(in), optional :: status
!! The `status` specifier for the `open` statement
integer, intent(out), optional :: stat
!! The error status on exit with the possible values
!! * `success` - no errors found
!! * `read_only_error` - file unopened as `action1 was `"read"` for an output
!! file
!! * `open_failure` - the `open` statement failed
!!##### Example
!!
!! program main
!! use stdlib_logger
!! ...
!! integer :: unit, stat
!! ...
!! call global_logger % add_log_file( 'error_log.txt', unit, &
!! position='asis', stat=stat )
!! if ( stat /= success ) then
!! error stop 'Unable to open "error_log.txt".'
!! end if
!! ...
!! end program main
character(16) :: aaction, aposition, astatus
integer :: aunit
character(128) :: iomsg
integer :: iostat
character(*), parameter :: procedure_name = 'add_log_file'
integer, allocatable :: dummy(:)
integer :: lun
integer :: i
aaction = optval(action, 'write')
aposition = optval(position, 'rewind')
astatus = optval(status, 'replace')
if ( len_trim(aaction) == 4 ) then
do i=1, 4
aaction(i:i) = to_lower(aaction(i:i))
end do
if ( aaction == 'read' ) then
if ( present( stat ) ) then
stat = read_only_error
return
else
error stop 'In ' // module_name // ' % ' // &
procedure_name // ' action is "read" which ' // &
'does not allow writes to the file.'
end if
end if
end if
open( newunit=aunit, file=filename, form='formatted', action=aaction, &
position=aposition, status=astatus, iostat=iostat, iomsg=iomsg, &
err=999 )
if ( allocated( self % log_units ) ) then
if ( size(self % log_units) == self % units ) then
allocate( dummy(2*self % units) )
do lun=1, self % units
dummy(lun) = self % log_units(lun)
end do
dummy(self % units+1:) = 0
call move_alloc( dummy, self % log_units )
end if
else
allocate( self % log_units(16) )
end if
self % log_units(self % units + 1 ) = aunit
self % units = self % units + 1
if ( present(unit) ) unit = aunit
if ( present(stat) ) stat = success
return
999 if (present(stat) ) then
stat = open_failure
return
else
call self % log_io_error( 'Unable to open ' // trim(filename), &
module = module_name, &
procedure = procedure_name, &
iostat = iostat, &
iomsg = iomsg )
error stop module_name // ' % ' // procedure_name // &
': Unable to open file'
end if
end subroutine add_log_file
subroutine add_log_unit( self, unit, stat )
!! version: experimental
!! Adds `unit` to the log file units in `log_units`. `unit` must be an `open`
!! file, of `form` `"formatted"`, with `"sequential"` `access`, and an `action`
!! of `"write"` or `"readwrite"`, otherwise either `stat`, if present, has a
!! value other than `success` and `unit` is not entered into `log_units`,
!! or, if `stat` is not presecn, processing stops.
!!([Specification](../page/specs/stdlib_logger.html#add_log_unit-add-a-unit-to-the-array-self-log_units))
class(logger_type), intent(inout) :: self
!! The logger variable to which the I/O unit is to be added
integer, intent(in) :: unit
!! The input logical unit number
integer, intent(out), optional :: stat
!! An error code with the possible values
!! * `success` - no problems were found
!! * `non_sequential_error` - `unit` did not have sequential access
!! * `read_only_error` - `unit` was not writeable
!! * `unformatted_in_error` - `unit` was an `'unformatted'` file
!! * `unopened_in_error` - `unit` was not opened
!!##### Example
!!
!! program main
!! use stdlib_logger
!! ...
!! character(256) :: iomsg
!! integer :: iostat, unit, stat
!! ...
!! open( newunit=unit, 'error_log.txt', form='formatted', &
!! status='replace', position='rewind', err=999, &
!! action='read', iostat=iostat, iomsg=iomsg )
!! ...
!! call global_logger % add_log_unit( unit, stat )
!! select case ( stat )
!! ...
!! case ( read_only_error )
!! error stop 'Unable to write to "error_log.txt".'
!! ...
!! end select
!! ...
!! 999 error stop 'Unable to open "error_log.txt".
!! ...
!! end program main
integer, allocatable :: dummy(:)
character(*), parameter :: procedure_name = 'set_log_unit'
integer :: lun
character(12) :: specifier
logical :: question
integer :: istat
call validate_unit()
if ( present(stat) ) then
if ( stat /= success ) return
end if
do lun = 1, self % units
! Check that unit is not already registered
if (self % log_units(lun) == unit ) return
end do
if ( allocated( self % log_units ) ) then
if ( size(self % log_units) == self % units ) then
allocate( dummy(2*self % units) )
do lun=1, self % units
dummy(lun) = self % log_units(lun)
end do
call move_alloc( dummy, self % log_units )
end if
else
allocate( self % log_units(16) )
end if
self % log_units(self % units + 1 ) = unit
self % units = self % units + 1
contains
subroutine validate_unit()
! Check that unit is not input_unit
if ( unit == input_unit ) then
if ( present(stat) ) then
stat = read_only_error
return
else
error stop 'unit in ' // module_name // ' % ' // &
procedure_name // ' must not be input_unit.'
end if
end if
! Check that unit is opened
inquire( unit, opened=question, iostat=istat )
if(istat /= 0) question = .false.
if ( .not. question ) then
if ( present(stat) ) then
stat = unopened_in_error
return
else
error stop 'unit in ' // module_name // ' % ' // &
procedure_name // ' is not open.'
end if
end if
! Check that unit is writeable
inquire( unit, write=specifier )
if ( specifier(1:1) /= 'Y' .and. specifier(1:1) /= 'y' ) then
if ( present(stat) ) then
stat = read_only_error
return
else
error stop 'unit in ' // module_name // ' % ' // &
procedure_name // ' is not writeable.'
end if
end if
inquire( unit, sequential=specifier )
if ( specifier(1:1) /= 'Y' .and. specifier(1:1) /= 'y' ) then
if ( present(stat) ) then
stat = non_sequential_error
return
else
error stop 'unit in ' // module_name // ' % ' // &
procedure_name // ' is not "sequential".'
end if
end if
inquire( unit, formatted=specifier )
if ( specifier(1:1) /= 'Y' .and. specifier(1:1) /= 'y' ) then
if ( present(stat) ) then
stat = unformatted_in_error
return
else
error stop 'unit in ' // module_name // ' % ' // &
procedure_name // ' is not "formatted".'
end if
end if
if ( present(stat) ) stat = success
end subroutine validate_unit
end subroutine add_log_unit
pure subroutine configuration( self, add_blank_line, indent, level, &
max_width, time_stamp, log_units )
!! version: experimental
!! Reports the logging configuration of `self`. The following attributes are
!! reported:
!! 1. `add_blank_line` is a logical flag with `.true.` implying that output
!! starts with a blank line, and `.false.` implying no blank line.
!! 2. `indent` is a logical flag with `.true.` implying that subsequent columns
!! will be indented 4 spaces and `.false.` implying no indentation.
!! 3. `level` is the lowest level for printing a message
!! 4. `max_width` is the maximum number of columns of output text with
!! `max_width` == 0 => no bounds on output width.
!! 5. `time_stamp` is a logical flag with `.true.` implying that the output
!! will have a time stamp, and `.false.` implying that there will be no
!! time stamp.
!! 6. `log_units` is an array of the I/O unit numbers to which log output
!! will be written.
!!([Specification](../page/specs/stdlib_logger.html#configuration-report-a-loggers-configuration))
class(logger_type), intent(in) :: self
!! The logger variable whose configuration is being reported
logical, intent(out), optional :: add_blank_line
!! A logical flag to add a preceding blank line
logical, intent(out), optional :: indent
!! A logical flag to indent subsequent lines
integer, intent(out), optional :: level
!! The minimum level for printing a message
integer, intent(out), optional :: max_width
!! The maximum number of columns for most outputs
logical, intent(out), optional :: time_stamp
!! A logical flag to add a time stamp
integer, intent(out), allocatable, optional :: log_units(:)
!! The I/O units used in output
!!##### Example
!!
!! module example_mod
!! use stdlib_logger
!! ...
!! contains
!! ...
!! subroutine example_sub(unit, ...)
!! integer, intent(in) :: unit
!! ...
!! integer, allocatable :: log_units(:)
!! ...
!! call global_logger % configuration( log_units=log_units )
!! if ( size(log_units) == 0 ) then
!! call add_logger_unit( unit )
!! end if
!! ..
!! end subroutine example_sub
!! ...
!! end module example_mod
if ( present(add_blank_line) ) add_blank_line = self % add_blank_line
if ( present(indent) ) indent = self % indent_lines
if ( present(level) ) level = self % level
if ( present(max_width) ) max_width = self % max_width
if ( present(time_stamp) ) time_stamp = self % time_stamp
if ( present(log_units) ) then
if ( self % units .gt. 0 ) then
log_units = self % log_units(1:self % units)
else
allocate(log_units(0))
end if
end if
end subroutine configuration
pure subroutine configure( self, add_blank_line, indent, level, max_width, &
time_stamp )
!! version: experimental
!! Configures the logging process for SELF. The following attributes are
!! configured:
!! 1. `add_blank_line` is a logical flag with `.true.` implying that output
!! starts with a blank line, and `.false.` implying no blank line.
!! `add_blank_line` has a startup value of `.false.`.
!! 2. `indent` is a logical flag with `.true.` implying that subsequent lines
!! will be indented 4 spaces and `.false.` implying no indentation. `indent`
!! has a startup value of `.true.`.
!! 3. `level` is the lowest level for printing a message
!! 4. `max_width` is the maximum number of columns of output text with
!! `max_width == 0` => no bounds on output width. `max_width` has a startup
!! value of 0.
!! 5. `time_stamp` is a logical flag with `.true.` implying that the output
!! will have a time stamp, and `.false.` implying that there will be no
!! time stamp. `time_stamp` has a startup value of `.true.`.
!!([Specification](../page/specs/stdlib_logger.html#configure-configure-the-logging-process))
!!##### Example
!!
!! program main
!! use stdlib_logger
!! ...
!! call global_logger % configure( indent=.false., max_width=72 )
!! ...
class(logger_type), intent(inout) :: self
logical, intent(in), optional :: add_blank_line
logical, intent(in), optional :: indent
integer, intent(in), optional :: level
integer, intent(in), optional :: max_width
logical, intent(in), optional :: time_stamp
if ( present(add_blank_line) ) self % add_blank_line = add_blank_line
if ( present(level) ) self % level = level
if ( present(indent) ) self % indent_lines = indent
if ( present(max_width) ) then
if ( max_width <= 4 ) then
self % max_width = 0
else
self % max_width = max_width
end if
end if
if ( present(time_stamp) ) self % time_stamp = time_stamp
end subroutine configure
subroutine final_logger( self )
!! version: experimental
!! Finalizes the `logger_type` entity `self` by flushing the units
type(logger_type), intent(in) :: self
integer :: iostat
character(256) :: message
integer :: unit
do unit=1, self % units
flush( self % log_units(unit), iomsg=message, iostat=iostat )
if ( iostat /= 0 ) then
write(error_unit, '(a, i0)' ) 'In the logger_type ' // &
'finalizer an error occurred in flushing unit = ', &
self % log_units(unit)
write(error_unit, '(a, i0)') 'With iostat = ', iostat
write(error_unit, '(a)') 'With iomsg = ' // trim(message)
end if
end do
end subroutine final_logger
subroutine format_output_string( self, string, col_indent, len_buffer, buffer )
!! version: experimental
!! Writes the STRING to UNIT ensuring that the number of characters
!! does not exceed MAX_WIDTH and that the lines after the first
!! one are indented four characters.
class(logger_type), intent(in) :: self
character(*), intent(in) :: string
character(*), intent(in) :: col_indent
integer, intent(out) :: len_buffer
character(len=:), allocatable, intent(out) :: buffer
integer :: count, indent_len, index_, length, remain
integer, parameter :: new_len = len(new_line('a'))
length = len_trim(string)
allocate( character(2*length) :: buffer )
len_buffer = 0
indent_len = len(col_indent)
call format_first_line()
if ( self % indent_lines ) then
do while( remain > 0 )
call indent_format_subsequent_line()
end do
else
do while( remain > 0 )
call format_subsequent_line()
end do
end if
contains
subroutine format_first_line()
if ( self % max_width == 0 .or. &
( length <= self % max_width .and. &
index( string(1:length), new_line('a')) == 0 ) ) then
buffer(1:length) = string(1:length)
len_buffer = length
remain = 0
return
else
index_ = index( string(1:min(length, self % max_width)), &
new_line('a') )
if ( index_ == 0 ) then
do index_=self % max_width, 1, -1
if ( string(index_:index_) == ' ' ) exit
end do
end if
if ( index_ == 0 ) then
buffer(1:self % max_width) = &
string(1:self % max_width)
len_buffer = self % max_width
count = self % max_width
remain = length - count
return
else
buffer(1:index_-1) = string(1:index_-1)
len_buffer = index_-1
count = index_
remain = length - count
return
end if
end if
end subroutine format_first_line
subroutine format_subsequent_line()
integer :: new_len_buffer
character(:), allocatable :: dummy
if ( remain <= self % max_width ) then
new_len_buffer = len_buffer + length - count + new_len
if ( new_len_buffer > len( buffer ) ) then
allocate( character( 2*len( buffer ) ) :: dummy )
dummy = buffer
call move_alloc( dummy, buffer )
end if
buffer( len_buffer+1:new_len_buffer ) = &
new_line('a') // string(count+1:length)
len_buffer = new_len_buffer
count = length
remain = 0
return
else
index_ = count + index(string(count+1:count+self % max_width),&
new_line('a'))
if(index_ == count) then
do index_=count+self % max_width, count+1, -1
if ( string(index_:index_) == ' ' ) exit
end do
end if
if ( index_ == count ) then
new_len_buffer = len_buffer + self % max_width + &
new_len
if ( new_len_buffer > len( buffer ) ) then
allocate( character( 2*len( buffer ) ) :: dummy )
dummy = buffer
call move_alloc( dummy, buffer )
end if
buffer( len_buffer+1:new_len_buffer ) = &
new_line('a') // string(count+1:count+self % max_width)
len_buffer = new_len_buffer
count = count + self % max_width
remain = length - count
return
else
new_len_buffer = len_buffer + index_ - 1 &
- count + new_len
if ( new_len_buffer > len( buffer ) ) then
allocate( character( 2*len( buffer ) ) :: dummy )
dummy = buffer
call move_alloc( dummy, buffer )
end if
buffer( len_buffer+1:new_len_buffer ) = &
new_line('a') // string(count+1:index_-1)
len_buffer = new_len_buffer
count = index_
remain = length - count
return
end if
end if
end subroutine format_subsequent_line
subroutine indent_format_subsequent_line()
integer :: new_len_buffer
character(:), allocatable :: dummy
if ( index( string(count+1:length), new_line('a')) == 0 .and. &
remain <= self % max_width - indent_len ) then
new_len_buffer = len_buffer + length &
- count + new_len + indent_len
if ( new_len_buffer > len( buffer ) ) then
allocate( character( 2*len( buffer ) ) :: dummy )
dummy = buffer
call move_alloc( dummy, buffer )
end if
buffer( len_buffer+1:new_len_buffer ) = &
new_line('a') // col_indent // string(count+1:length)
len_buffer = new_len_buffer
count = length
remain = 0
return
else
index_ = count + index( string(count+1: &
min ( length, count+self % max_width - indent_len) ), &
new_line('a'))
if(index_ == count) then
do index_=count+self % max_width-indent_len, count+1, -1
if ( string(index_:index_) == ' ' ) exit
end do
end if
if ( index_ == count ) then
new_len_buffer = len_buffer + self % max_width &
+ new_len
if ( new_len_buffer > len( buffer ) ) then
allocate( character( 2*len( buffer ) ) :: dummy )
dummy = buffer
call move_alloc( dummy, buffer )
end if
buffer( len_buffer+1: new_len_buffer ) = &
new_line('a') // col_indent // &
string(count+1:count+self % max_width-indent_len)
len_buffer = new_len_buffer
count = count + self % max_width - indent_len
remain = length - count
return
else
new_len_buffer = len_buffer + index_ - count - 1 &
+ new_len + indent_len
if ( new_len_buffer > len( buffer ) ) then
allocate( character( 2*len( buffer ) ) :: dummy )
dummy = buffer
call move_alloc( dummy, buffer )
end if
buffer( len_buffer+1: new_len_buffer ) = &
new_line('a') // col_indent // string(count+1:index_-1)
len_buffer = new_len_buffer
count = index_
remain = length - count
return
end if
end if
end subroutine indent_format_subsequent_line
end subroutine format_output_string
subroutine handle_write_failure( unit, procedure_name, iostat, iomsg )
!! version: experimental
!! Handles a failure to write to `unit` in `procedure_name` with `iostat` and
!! `iomsg` by writing a description of the failure to `output_unit` and
!! stopping.
integer, intent(in) :: unit
character(*), intent(in) :: procedure_name
integer, intent(in) :: iostat
character(*), intent(in) :: iomsg
character(256) :: name
logical :: named
character(10) :: action
write( output_unit, '(a)' ) 'write failure in ' // module_name // &
' % ' // trim(procedure_name) // '.'
if ( unit == -999 ) then
write( output_unit, '(a, i0)' ) 'unit = internal file'
else
write( output_unit, '(a, i0)' ) 'unit = ', unit
inquire( unit, named=named )
if ( named ) then
inquire( unit, name=name )
write( output_unit, '(a, a)' ) 'name = ', trim(name)
else
write( output_unit, '(a)' ) 'unit is unnamed'
end if
inquire( unit, action=action )
write( output_unit, '(a, a)' ) 'action = ', trim(action)
end if
write( output_unit, '(a, i0)' ) 'iostat = ', iostat
write( output_unit, '(a, a )' ) 'iomsg = ', trim(iomsg)
error stop 'write failure in ' // module_name // '.'
end subroutine handle_write_failure
subroutine log_debug( self, message, module, procedure )
!! version: experimental
!! Writes the string `message` to `self % log_units` with optional additional
!! text.
!!([Specification](../page/specs/stdlib_logger.html#log_debug-writes-the-string-message-to-self-log_units))
!!
!!##### Behavior
!!
!! If time stamps are active, a time stamp is written, followed by
!! `module` and `procedure` if present, and then `message` is
!! written with the prefix 'DEBUG: '.
!!
!!##### Example
!!
!! module example_mod
!! use stdlib_logger
!! ...
!! real, allocatable :: a(:)
!! ...
!! type(logger_type) :: alogger
!! ...
!! contains
!! ...
!! subroutine example_sub( selection )
!! integer, intent(out) :: selection
!! integer :: stat
!! write(*,'(a)') "Enter an integer to select a widget"
!! read(*,'(i0)') selection
!! write( message, `(a, i0)' ) &
!! "The user selected ", selection
!! call alogger % log_debug( message, &
!! module = 'EXAMPLE_MOD', &
!! procedure = 'EXAMPLE_SUB' )
!! ...
!! end subroutine example_sub
!! ...
!! end module example_mod
!!
class(logger_type), intent(in) :: self
!! The logger used to send the message
character(len=*), intent(in) :: message
!! A string to be written to log_unit
character(len=*), intent(in), optional :: module
!! The name of the module containing the current invocation of `log_information`
character(len=*), intent(in), optional :: procedure
!! The name of the procedure containing the current invocation of
!! `log_information`
if ( self % level > debug_level ) return
call self % log_message( message, &
module = module, &
procedure = procedure, &
prefix = 'DEBUG' )
end subroutine log_debug
subroutine log_error( self, message, module, procedure, stat, errmsg )
!! version: experimental
!! Writes the string `message` to `self % log_units` with optional additional
!! text.
!! ([Specification](../specs/stdlib_logger.html#log_error-writes-the-string-message-to-self-log_units))
!!##### Behavior
!!
!! If time stamps are active, a time stamp is written, followed by
!! `module` and `procedure` if present, then `message` is
!! written with the prefix 'ERROR: ', and then if `stat` or `errmsg`
!! are present they are written.
!!
!!##### Example
!!
!! module example_mod
!! use stdlib_logger
!! ...
!! real, allocatable :: a(:)
!! ...
!! type(logger_type) :: alogger
!! ...
!! contains
!! ...
!! subroutine example_sub( size )
!! integer, intent(in) :: size
!! character(128) :: errmsg, message
!! integer :: stat
!! allocate( a(size), stat=stat, errmsg=errmsg )
!! if ( stat /= 0 ) then
!! write( message, `(a, i0)' ) &
!! "Allocation of A failed with SIZE = ", size
!! alogger % call log_error( message, &
!! module = 'EXAMPLE_MOD', &
!! procedure = 'EXAMPLE_SUB', &
!! stat = stat, &
!! errmsg = errmsg )
!! end if
!! end subroutine example_sub
!! ...
!! end module example_mod
!!
class(logger_type), intent(in) :: self
!! The logger to be used in logging the message
character(len=*), intent(in) :: message
!! A string to be written to log_unit
character(len=*), intent(in), optional :: module
!! The name of the module containing the current invocation of `log_error`
character(len=*), intent(in), optional :: procedure
!! The name of the procedure containing the current invocation of `log_error`
integer, intent(in), optional :: stat
!! The value of the `stat` specifier returned by a Fortran statement
character(len=*), intent(in), optional :: errmsg
!! The value of the `errmsg` specifier returned by a Fortran statement
integer :: iostat
character(28) :: dummy
character(256) :: iomsg
character(*), parameter :: procedure_name = 'log_error'
character(:), allocatable :: suffix
if ( self % level > error_level ) return
if ( present(stat) ) then
write( dummy, '(a, i0)', err=999, iostat=iostat, iomsg=iomsg ) &
new_line('a') // "With stat = ", stat
else
dummy = ' '
end if
if ( present(errmsg) ) then
if ( len_trim(errmsg) > 0 ) then
suffix = trim(dummy) // &
new_line('a') // 'With errmsg = "' // trim(errmsg) // '"'
else
suffix = dummy
end if
else
suffix = dummy
end if
call self % log_message( trim(message) // suffix, &
module = module, &
procedure = procedure, &
prefix = 'ERROR')
return
999 call handle_write_failure( -999, procedure_name, iostat, iomsg )
end subroutine log_error
subroutine log_information( self, message, module, procedure )
!! version: experimental
!! Writes the string `message` to `self % log_units` with optional additional
!! text.
!!([Specification](../page/specs/stdlib_logger.html#log_information-writes-the-string-message-to-self-log_units))
!!
!!##### Behavior
!!
!! If time stamps are active, a time stamp is written, followed by
!! `module` and `procedure` if present, and then `message` is
!! written with the prefix 'INFO: '.
!!
!!##### Example
!!
!! module example_mod
!! use stdlib_logger
!! ...
!! real, allocatable :: a(:)
!! ...
!! type(logger_type) :: alogger
!! ...
!! contains
!! ...
!! subroutine example_sub( selection )
!! integer, intent(out) :: selection
!! integer :: stat
!! write(*,'(a)') "Enter an integer to select a widget"
!! read(*,'(i0)') selection
!! write( message, `(a, i0)' ) &
!! "The user selected ", selection
!! call alogger % log_information( message, &
!! module = 'EXAMPLE_MOD', &
!! procedure = 'EXAMPLE_SUB' )
!! ...
!! end subroutine example_sub
!! ...
!! end module example_mod
!!
class(logger_type), intent(in) :: self
!! The logger used to send the message
character(len=*), intent(in) :: message
!! A string to be written to log_unit
character(len=*), intent(in), optional :: module
!! The name of the module containing the current invocation of `log_information`
character(len=*), intent(in), optional :: procedure
!! The name of the procedure containing the current invocation of
!! `log_information`
if ( self % level > information_level ) return
call self % log_message( message, &
module = module, &
procedure = procedure, &
prefix = 'INFO' )
end subroutine log_information
subroutine log_io_error( self, message, module, procedure, iostat, &
iomsg )
!! version: experimental
!! Writes the string `message` to the `self % log_units` with optional
!! additional text.
!!([Specification](../page/specs/stdlib_logger.html#log_io_error-write-the-string-message-to-self-log_units))
!!
!!##### Behavior
!!
!! If time stamps are active, a time stamp is written, followed by
!! `module` and `procedure` if present, then `message` is
!! written with a prefix 'I/O ERROR: ', and then if `iostat` or `iomsg`
!! are present they are also written.
!!
!!##### Example
!!
!! program example
!! use stdlib_logger
!! ...
!! character(*), parameter :: filename = 'dummy.txt'
!! integer :: iostat, lun
!! character(128) :: iomsg
!! character(*), parameter :: message = 'Failure in opening "dummy.txt".'
!!
!! open( newunit=lun, file = filename, form='formatted', &
!! status='old', iostat=iostat, iomsg=iomsg )
!! if ( iostat /= 0 ) then
!! call global_logger % log_io_error( message, procedure = 'EXAMPLE', &
!! iostat=iostat, iomsg = iomsg )
!! error stop 'Error on opening ' // filename
!! end if
!! ...
!! end program example
class(logger_type), intent(in) :: self
!! The logger variable to receivee the message
character(len=*), intent(in) :: message
!! A string to be written to LOG_UNIT
character(len=*), intent(in), optional :: module
!! The name of the module containing the current invocation of REPORT_ERROR
character(len=*), intent(in), optional :: procedure
!! The name of the procedure containing the current invocation of REPORT_ERROR
integer, intent(in), optional :: iostat
!! The value of the IOSTAT specifier returned by a Fortran I/O statement
character(len=*), intent(in), optional :: iomsg
!! The value of the IOMSG specifier returned by a Fortran I/O statement
character(28) :: dummy
character(256) :: iomsg2
integer :: iostat2
character(*), parameter :: procedure_name = 'log_io_error'
character(:), allocatable :: suffix
if ( self % level > io_error_level ) return
if ( present(iostat) ) then
write( dummy, '(a, i0)', err=999, iostat=iostat2, iomsg=iomsg2 ) &
new_line('a') // "With iostat = ", iostat
else
dummy = ' '
end if
if ( present(iomsg) ) then
if ( len_trim(iomsg) > 0 ) then
suffix = trim(dummy) // &
new_line('a') // 'With iomsg = "' // trim(iomsg) // '"'
else
suffix = trim(dummy)
end if
else
suffix = trim(dummy)
end if
call self % log_message( trim(message) // suffix, &
module = module, &
procedure = procedure, &
prefix = 'I/O ERROR' )
return
999 call handle_write_failure( -999, procedure_name, iostat2, iomsg2 )
end subroutine log_io_error
subroutine log_message( self, message, module, procedure, prefix )
!! version: experimental
!! Writes the string `message` to the `self % log_units` with optional
!! additional text.
!!([Specification](../page/specs/stdlib_logger.html#log_message-write-the-string-message-to-self-log_units))
!!
!!##### Behavior
!!
!! If time stamps are active, a time stamp is written, followed by `module`
!! and `procedure` if present, followed by `prefix // ': '` if present,
!! and then `message`.
!!
!!##### Example
!!
!! module example_mod
!! use stdlib_logger
!! ...
!! real, allocatable :: a(:)
!! ...
!! contains
!! ...
!! subroutine example_sub( selection )
!! integer, intent(out) :: selection
!! integer :: stat
!! write(*,'(a)') "Enter an integer to select a widget"
!! read(*,'(i0)') selection
!! write( message, `(a, i0)' ) &
!! "The user selected ", selection
!! call global_logger % log_message( message, &
!! module = 'example_mod', &
!! procedure = 'example_sub', &
!! prefix = 'info' )
!! end subroutine example_sub
!! ...
!! end module example_mod
!!
class(logger_type), intent(in) :: self
!! The logger variable to receive the message
character(len=*), intent(in) :: message
!! A string to be written to log_unit
character(len=*), intent(in), optional :: module
!! The name of the module containing the current invocation of `log_message`
character(len=*), intent(in), optional :: procedure
!! The name of the procedure containing the current invocation of `log_message`
character(len=*), intent(in), optional :: prefix
!! To be prepended to message as `prefix // ': ' // message`.
integer :: unit
integer :: iostat
integer :: len_buffer
character(*), parameter :: procedure_name = 'log_message'
character(256) :: iomsg
character(:), allocatable :: d_and_t, m_and_p, pref
character(:), allocatable :: buffer
pref = optval(prefix, '')
if ( len(pref) > 0 ) pref = pref // ': '
if ( self % time_stamp ) then
d_and_t = time_stamp() // ': '
else
d_and_t = ''
end if
if ( present(module) ) then
if ( present(procedure) ) then
m_and_p = trim(module) // ' % ' // trim(procedure) // ': '
else
m_and_p = trim(module) // ': '
end if
else if ( present(procedure) ) then
m_and_p = trim(procedure) // ': '
else
m_and_p = ''
end if
call format_output_string( self, &
d_and_t // m_and_p // pref // &
trim( message ), &
' ', &
len_buffer, &
buffer)
if ( self % units == 0 ) then
if ( self % add_blank_line ) then
write( output_unit, '(a)', err=999, iostat=iostat, &
iomsg=iomsg) &
new_line('a') // buffer(1:len_buffer)
else
write( output_unit, '(a)', err=999, iostat=iostat, &
iomsg=iomsg ) &
buffer(1:len_buffer)
end if
else
if ( self % add_blank_line ) then
do unit=1, self % units
write( self % log_units(unit), '(a)', err=999, iostat=iostat, &
iomsg=iomsg ) new_line('a') // &
buffer(1:len_buffer)
end do
else
do unit=1, self % units
write( self % log_units(unit), '(a)', err=999, iostat=iostat, &
iomsg=iomsg ) &
buffer(1:len_buffer)
end do
end if
end if
return
999 call handle_write_failure( unit, procedure_name, iostat, iomsg )
end subroutine log_message
subroutine log_text_error( self, line, column, summary, filename, &
line_number, caret, stat )
!! version: experimental
!! Sends a message to `self % log_units` describing an error found
!! in a line of text.
!!([Specification](../page/specs/stdlib_logger.html#log_text_error-send-a-message-to-self-log_units-describing-an-error))
!!##### Behavior
!!
!! If time stamps are active first a time stamp is written. Then if
!! `filename` or `line_number` or `column` are present they are written.
!! Then `line` is written. Then the symbol `caret` is written below `line`
!! at the column indicated by `column`. Then `summary` is written.
!
!!##### Example
!!
!! program example
!! ...
!! character(*), parameter :: filename = 'dummy.txt'
!! integer :: col_num, line_num, lun
!! character(128) :: line
!! character(*), parameter :: message = 'Bad text found.'
!!
!! open( newunit=lun, file = filename, statu='old', form='formatted' )
!! line_num = 0
!! do
!! read( lun, fmt='(a)', end=900 ) line
!! line_num = line_num + 1
!! call check_line( line, status, col_num )
!! if ( status /= 0 )
!! call global_logger % log_text_error( line, col_num, message, &
!! filename, line_num )
!! error stop 'Error in reading ' // filename
!! end if
!! ...
!! end do
!!900 continue
!! ...
!! end program example
!!
class(logger_type), intent(in) :: self
!! The logger variable to receive the message
character(*), intent(in) :: line
!! The line of text in which the error was found.
integer, intent(in) :: column
!! The one's based column in LINE at which the error starts.
character(*), intent(in) :: summary
!! A brief description of the error.
character(*), intent(in), optional :: filename
!! The name of the file, if any, in which the error was found.
integer, intent(in), optional :: line_number
!! The one's based line number in the file where `line` was found.
character(1), intent(in), optional :: caret
!! The symbol used to mark the column wher the error was first detected
integer, intent(out), optional :: stat
!! Integer flag that an error has occurred. Has the value `success` if no
!! error hass occurred, `index_invalid_error` if `column` is less than zero or
!! greater than `len(line)`, and `write_failure` if any of the `write`
!! statements has failed.
character(1) :: acaret
character(128) :: iomsg
integer :: iostat
integer :: lun
character(*), parameter :: procedure_name = 'LOG_TEXT_ERROR'
character(len=:), allocatable :: buffer
if ( self % level > text_error_level ) return
acaret = optval(caret, '^')
if ( column < 0 .or. column > len( line ) + 1 ) then
if ( present(stat) ) then
stat = index_invalid_error
return
else
call self % log_error( invalid_column, &
module = module_name, &
procedure = procedure_name )
error stop module_name // ' % ' // procedure_name // ': ' // &
invalid_column
end if
end if
call write_log_text_error_buffer( )
if ( self % units == 0 ) then
write( output_unit, '(a)' ) buffer
else
do lun=1, self % units
write( self % log_units(lun), '(a)' ) buffer
end do
end if
contains
subroutine write_log_text_error_buffer( )
integer :: i
character(:), allocatable :: location, marker
if ( present(filename) ) then
if ( present(line_number) ) then
allocate( character(len_trim(filename)+15) :: location )
write( location, fmt='(a, ":", i0, ":", i0)', err=999, &
iomsg=iomsg, iostat=iostat ) &
trim(filename) , line_number, column
else
allocate( character(len_trim(filename)+45) :: location )
write( location, fmt='(a, i0)', err=999, iomsg=iomsg, &
iostat=iostat ) &
"Error found in file: '" // trim(filename) // &
"', at column: ", column
end if
else
if ( present(line_number) ) then
allocate( character(54) :: location )
write( location, fmt='(a, i0, a, i0)', err=999, &
iomsg=iomsg, iostat=iostat ) &
'Error found at line number: ', line_number, &
', and column: ', column
else
allocate( character(36) :: location )
write( location, &
fmt='("Error found in line at column:", i0)' ) &
column
end if
end if
allocate( character(column) :: marker )
do i=1, column-1
marker(i:i) = ' '
end do
marker(column:column) = acaret
if ( self % add_blank_line ) then
if ( self % time_stamp ) then
buffer = new_line('a') // time_stamp() // &
new_line('a') // trim(location) // &
new_line('a') // new_line('a') // trim(line) // &
new_line('a') // marker // &
new_line('a') // 'Error: ' // trim(summary)
else
buffer = new_line('a') // trim(location) // &
new_line('a') // new_line('a') // trim(line) // &
new_line('a') // marker // &
new_line('a') // 'Error: ' // trim(summary)
end if
else
if ( self % time_stamp ) then
buffer = time_stamp() // &
new_line('a') // trim(location) // &
new_line('a') // new_line('a') // trim(line) // &
new_line('a') // marker // &
new_line('a') // 'Error: ' // trim(summary)
else
buffer = trim(location) // &
new_line('a') // new_line('a') // trim(line) // &
new_line('a') // marker // &
new_line('a') // 'Error: ' // trim(summary)
end if
end if
if ( present(stat) ) stat = success
return
999 if ( present( stat ) ) then
stat = write_failure
return
else
call handle_write_failure( -999, procedure_name, iostat, &
iomsg )
end if
end subroutine write_log_text_error_buffer
end subroutine log_text_error
elemental function log_units_assigned(self)
!! version: experimental
!! Returns the number of units assigned to `self % log_units`
!!([Specification](../page/specs/stdlib_logger.html#log_units_assigned-returns-the-number-of-active-io-units))
class(logger_type), intent(in) :: self
!! The logger subject to the inquiry
integer :: log_units_assigned
!!##### Example
!!
!! module example_mod
!! use stdlib_logger
!! ...
!! type(logger_type) :: alogger
!! ...
!! contains
!! ...
!! subroutine example_sub(unit, ...)
!! integer, intent(in) :: unit
!! ...
!! integer, allocatable :: log_units(:)
!! ...
!! if ( alogger % log_units_assigned() == 0 ) then
!! call alogger % add_log_unit( unit )
!! end if
!! ...
!! end subroutine example_sub
!! ...
!! end module example_mod
log_units_assigned = self % units
end function log_units_assigned
subroutine log_warning( self, message, module, procedure )
!! version: experimental
!! Writes the string `message` to `self % log_units` with optional additional
!! text.
!!([Specification](../page/specs/stdlib_logger.html#log_warning-write-the-string-message-to-log_units))
!!##### Behavior
!!
!! If time stamps are active, a time stamp is written, followed by
!! `module` and `procedure` if present, then `message` is
!! written with the prefix 'WARN: '.
!!
!!##### Example
!!
!! module example_mod
!! use stdlib_logger
!! ...
!! real, allocatable :: a(:)
!! ...
!! type(logger_type) :: alogger
!! ...
!! contains
!! ...
!! subroutine example_sub( size, stat )
!! integer, intent(in) :: size
!! integer, intent(out) :: stat
!! allocate( a(size) )
!! if ( stat /= 0 ) then
!! write( message, `(a, i0)' ) &
!! "Allocation of A failed with SIZE = ", size
!! call alogger % log_warning( message, &
!! module = 'EXAMPLE_MOD', &
!! procedure = 'EXAMPLE_SUB' )
!! end if
!! end subroutine example_sub
!! ...
!! end module example_mod
!!
class(logger_type), intent(in) :: self
!! The logger to which the message is written
character(len=*), intent(in) :: message
!! A string to be written to LOG_UNIT
character(len=*), intent(in), optional :: module
!! The name of the module containing the current invocation of `log_warning`
character(len=*), intent(in), optional :: procedure
!! The name of the procedure containing the current invocation of `log_warning`
if ( self % level > warning_level ) return
call self % log_message( message, &
module = module, &
procedure = procedure, &
prefix = 'WARN' )
end subroutine log_warning
subroutine remove_log_unit( self, unit, close_unit, stat )
!! version: experimental
!! Remove the I/O unit from the self % log_units list. If `close_unit` is
!! present and `.true.` then the corresponding file is closed. If `unit` is
!! not in `log_units` then nothing is done. If `stat` is present it, by
!! default, has the value `success`. If closing the `unit` fails, then if
!! `stat` is present it has the value `close_failure`, otherwise processing
!! stops with an informative message.
!!([Specification](../page/specs/stdlib_logger.html#remove_log_unit-remove-unit-from-self-log_units))
class(logger_type), intent(inout) :: self
!! The logger variable whose unit is to be removed
integer, intent(in) :: unit
!! The I/O unit to be removed from self
logical, intent(in), optional :: close_unit
!! A logical flag to close the unit while removing it from the SELF list
integer, intent(out), optional :: stat
!! An error status with the values
!! * success - no problems found
!! * close_failure - the close statement for unit failed
!!
!!##### Example
!!
!! module example_mod
!! use stdlib_logger
!! ...
!! type(logger_type) :: alogger
!! contains
!! ...
!! subroutine example_sub(unit, ...)
!! integer, intent(in) :: unit
!! ...
!! call alogger % remove_log_unit( unit )
!! ...
!! end subroutine example_sub
!! ...
!! end module example_mod
character(128) :: errmsg
integer :: lun, lun_old
character(*), parameter :: procedure_name = 'REMOVE_LOG_UNIT'
if ( present(stat) ) stat = success
do lun=1, self % units
if ( unit == self % log_units(lun) ) exit
end do
if ( lun == self % units + 1 ) return
if ( present(close_unit) ) then
if ( close_unit ) close( unit, err=999, iomsg=errmsg )
end if
do lun_old=lun+1, self % units
self % log_units(lun_old-1) = self % log_units(lun_old)
end do
self % units = self % units - 1
return
999 if ( present(stat) ) then
stat = close_failure
return
else
write(*, '(a, i0)') 'In ' // module_name // ' % ' // &
procedure_name // ' close_unit failed for unit = ', unit
write(*, '(a)' ) 'With iomsg = ' // trim(errmsg)
error stop 'close_unit failed in ' // module_name // ' % ' // &
procedure_name // '.'
end if
end subroutine remove_log_unit
function time_stamp()
!! Creates a time stamp in the format 'yyyy-mm-dd hh:mm:ss.sss'
character(23) :: time_stamp
character(8) :: date
character(10) :: time
call date_and_time( date, time )
time_stamp(1:4) = date(1:4)
time_stamp(5:5) = '-'
time_stamp(6:7) = date(5:6)
time_stamp(8:8) = '-'
time_stamp(9:10) = date(7:8)
time_stamp(11:11) = ' '
time_stamp(12:13) = time(1:2)
time_stamp(14:14) = ':'
time_stamp(15:16) = time(3:4)
time_stamp(17:17) = ':'
time_stamp(18:23) = time(5:10)
end function time_stamp
end module stdlib_logger
fortran-lang-stdlib-0ede301/src/linalg/ 0000775 0001750 0001750 00000000000 15135654166 020223 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_outer_product.fypp 0000664 0001750 0001750 00000001025 15135654166 026706 0 ustar alastair alastair #:include "common.fypp"
#:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES
submodule (stdlib_linalg) stdlib_linalg_outer_product
implicit none
contains
#:for k1, t1 in RCI_KINDS_TYPES
pure module function outer_product_${t1[0]}$${k1}$(u, v) result(res)
${t1}$, intent(in) :: u(:), v(:)
${t1}$ :: res(size(u),size(v))
integer :: col
do col = 1, size(v)
res(:,col) = v(col) * u
end do
end function outer_product_${t1[0]}$${k1}$
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_norms.fypp 0000664 0001750 0001750 00000056715 15135654166 025166 0 ustar alastair alastair #:include "common.fypp"
#:set ALL_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#! Allow for integer or character norm input: i.e., norm(a,2) or norm(a, '2')
#:set INPUT_TYPE = ["character(len=*)","integer(ilp)"]
#:set INPUT_SHORT = ["char","int"]
#:set INPUT_OPTIONS = list(zip(INPUT_TYPE,INPUT_SHORT))
! Vector norms
submodule(stdlib_linalg) stdlib_linalg_norms
use stdlib_linalg_constants
use stdlib_linalg_blas
use stdlib_linalg_lapack
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
use iso_c_binding, only: c_intptr_t,c_char,c_loc
implicit none
character(*), parameter :: this = 'norm'
!> List of internal norm flags
integer(ilp), parameter :: NORM_ONE = 1_ilp
integer(ilp), parameter :: NORM_TWO = 2_ilp
integer(ilp), parameter :: NORM_POW_FIRST = 3_ilp
integer(ilp), parameter :: NORM_INF = +huge(0_ilp) ! infinity norm
integer(ilp), parameter :: NORM_POW_LAST = NORM_INF - 1_ilp
integer(ilp), parameter :: NORM_MINUSINF = -huge(0_ilp)
!> Wrappers to LAPACK *LANGE matrix norm flags
character, parameter :: MAT_NORM_MAT = 'M' ! maxval(sum(abs(a))) ! over whole matrix: unused
character, parameter :: MAT_NORM_ONE = '1' ! maxval(sum(abs(a),1)) ! over columns
character, parameter :: MAT_NORM_INF = 'I' ! maxval(sum(abs(a),2)) ! over rows
character, parameter :: MAT_NORM_FRO = 'E' ! sqrt(sum(a**2)) ! "Euclidean" or "Frobenius"
!> Other wrappers to matrix norms
character, parameter :: MAT_NORM_SVD = '2' ! maxval(svdvals(a)) ! Maximum singular value
interface parse_norm_type
module procedure parse_norm_type_integer
module procedure parse_norm_type_character
end interface parse_norm_type
interface mat_task_request
module procedure mat_task_request_integer
module procedure mat_task_request_character
end interface mat_task_request
interface stride_1d
#:for rk,rt,ri in ALL_KINDS_TYPES
module procedure stride_1d_${ri}$
#:endfor
end interface stride_1d
contains
!> Parse norm type from an integer user input
pure subroutine parse_norm_type_integer(order,norm_type,err)
!> User input value
integer(ilp), intent(in) :: order
!> Return value: norm type
integer(ilp), intent(out) :: norm_type
!> State return flag
type(linalg_state_type), intent(out) :: err
select case (order)
case (1_ilp)
norm_type = NORM_ONE
case (2_ilp)
norm_type = NORM_TWO
case (3_ilp:NORM_POW_LAST)
norm_type = order
case (NORM_INF:)
norm_type = NORM_INF
case (:NORM_MINUSINF)
norm_type = NORM_MINUSINF
case default
norm_type = NORM_ONE
err = linalg_state_type(this,LINALG_ERROR,'Input norm type ',order,' is not recognized.')
end select
end subroutine parse_norm_type_integer
pure subroutine parse_norm_type_character(order,norm_type,err)
!> User input value
character(len=*), intent(in) :: order
!> Return value: norm type
integer(ilp), intent(out) :: norm_type
!> State return flag
type(linalg_state_type), intent(out) :: err
integer(ilp) :: int_order,read_err
select case (order)
case ('inf','Inf','INF')
norm_type = NORM_INF
case ('-inf','-Inf','-INF')
norm_type = NORM_MINUSINF
case ('Euclidean','euclidean','EUCLIDEAN')
norm_type = NORM_TWO
case default
! Check if this input can be read as an integer
read(order,*,iostat=read_err) int_order
if (read_err/=0) then
! Cannot read as an integer
norm_type = NORM_ONE
err = linalg_state_type(this,LINALG_ERROR,'Input norm type ',order,' is not recognized.')
else
call parse_norm_type_integer(int_order,norm_type,err)
endif
end select
end subroutine parse_norm_type_character
!> From a user norm request, generate a *LANGE task command
pure subroutine mat_task_request_integer(order,mat_task,err)
!> Parsed matrix norm type
integer(ilp), optional, intent(in) :: order
!> LANGE task
character, intent(out) :: mat_task
!> Error flag
type(linalg_state_type), intent(inout) :: err
if (present(order)) then
select case (order)
case (NORM_INF)
mat_task = MAT_NORM_INF
case (NORM_TWO)
mat_task = MAT_NORM_SVD
case (NORM_ONE)
mat_task = MAT_NORM_ONE
case default
err = linalg_state_type(this,LINALG_VALUE_ERROR,'Integer order ',order,' is not a valid matrix norm input.')
end select
else
! No user input: Frobenius norm
mat_task = MAT_NORM_FRO
endif
end subroutine mat_task_request_integer
pure subroutine mat_task_request_character(order,mat_task,err)
!> User input value
character(len=*), intent(in) :: order
!> Return value: norm type
character, intent(out) :: mat_task
!> State return flag
type(linalg_state_type), intent(out) :: err
integer(ilp) :: int_order,read_err
select case (order)
case ('inf','Inf','INF')
mat_task = MAT_NORM_INF
case ('Euclidean','euclidean','EUCLIDEAN','Frobenius','frobenius','FROBENIUS','Fro','fro','frob')
mat_task = MAT_NORM_FRO
case default
! Check if this input can be read as an integer
read(order,*,iostat=read_err) int_order
if (read_err/=0 .or. all(int_order/=[1,2])) then
! Cannot read as an integer
err = linalg_state_type(this,LINALG_ERROR,'Matrix norm input',order,' is not recognized.')
endif
select case (int_order)
case (1); mat_task = MAT_NORM_ONE
case (2); mat_task = MAT_NORM_SVD
case default; mat_task = MAT_NORM_ONE
end select
end select
end subroutine mat_task_request_character
#:for rk,rt,ri in ALL_KINDS_TYPES
! Compute stride of a 1d array
pure integer(ilp) function stride_1d_${ri}$(a) result(stride)
!> Input 1-d array
${rt}$, intent(in), target :: a(:)
integer(c_intptr_t) :: a1,a2
if (size(a,kind=ilp)<=1_ilp) then
stride = 1_ilp
else
a1 = transfer(c_loc(a(1)),a1)
a2 = transfer(c_loc(a(2)),a2)
stride = bit_size(0_c_char)*int(a2-a1, ilp)/storage_size(a, kind=ilp)
endif
end function stride_1d_${ri}$
! Private internal 1D implementation. This has to be used only internally,
! when all inputs are already checked for correctness.
pure subroutine internal_norm_1D_${ri}$(sze, a, nrm, norm_request)
!> Input matrix length
integer(ilp), intent(in) :: sze
!> Input contiguous 1-d matrix a(*)
${rt}$, intent(in) :: a(sze)
!> Norm of the matrix.
real(${rk}$), intent(out) :: nrm
!> Internal matrix request
integer(ilp), intent(in) :: norm_request
integer(ilp) :: i
real(${rk}$) :: rorder
! Initialize norm to zero
nrm = 0.0_${rk}$
select case(norm_request)
case(NORM_ONE)
nrm = asum(sze,a,incx=1_ilp)
case(NORM_TWO)
nrm = nrm2(sze,a,incx=1_ilp)
case(NORM_INF)
#:if rt.startswith('complex')
! The default BLAS stdlib_i${ri}$amax uses |Re(.)|+|Im(.)|. Do not use it.
i = stdlib_i${ri}$max1(sze,a,incx=1_ilp)
#:else
i = stdlib_i${ri}$amax(sze,a,incx=1_ilp)
#:endif
nrm = abs(a(i))
case(NORM_MINUSINF)
nrm = minval( abs(a) )
case (NORM_POW_FIRST:NORM_POW_LAST)
rorder = 1.0_${rk}$ / norm_request
nrm = sum( abs(a) ** norm_request ) ** rorder
end select
end subroutine internal_norm_1D_${ri}$
#:for it,ii in INPUT_OPTIONS
!==============================================
! Norms : any rank to scalar
!==============================================
#:for rank in range(1, MAXRANK + 1)
! Pure function interface, with order specification. On error, the code will stop
pure module function stdlib_linalg_norm_${rank}$D_order_${ii}$_${ri}$(a, order) result(nrm)
!> Input ${rank}$-d matrix a${ranksuffix(rank)}$
${rt}$, intent(in) :: a${ranksuffix(rank)}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> Norm of the matrix.
real(${rk}$) :: nrm
call norm_${rank}$D_${ii}$_${ri}$(a, nrm=nrm, order=order)
end function stdlib_linalg_norm_${rank}$D_order_${ii}$_${ri}$
! Function interface with output error
module function stdlib_linalg_norm_${rank}$D_order_err_${ii}$_${ri}$(a, order, err) result(nrm)
!> Input ${rank}$-d matrix a${ranksuffix(rank)}$
${rt}$, intent(in) :: a${ranksuffix(rank)}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> Output state return flag.
type(linalg_state_type), intent(out) :: err
!> Norm of the matrix.
real(${rk}$) :: nrm
call norm_${rank}$D_${ii}$_${ri}$(a, nrm=nrm, order=order, err=err)
end function stdlib_linalg_norm_${rank}$D_order_err_${ii}$_${ri}$
! Internal implementation: ${rank}$-d
pure module subroutine norm_${rank}$D_${ii}$_${ri}$(a, nrm, order, err)
!> Input ${rank}$-d matrix a${ranksuffix(rank)}$
${rt}$, intent(in), target :: a${ranksuffix(rank)}$
!> Norm of the matrix.
real(${rk}$), intent(out) :: nrm
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out), optional :: err
type(linalg_state_type) :: err_
integer(ilp) :: sze,norm_request
sze = size(a,kind=ilp)
! Initialize norm to zero
nrm = 0.0_${rk}$
! Check matrix size
if (sze<=0) then
err_ = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix shape: a=',shape(a,kind=ilp))
call linalg_error_handling(err_,err)
return
end if
! Check norm request
call parse_norm_type(order,norm_request,err_)
if (err_%error()) then
call linalg_error_handling(err_,err)
return
endif
! Get norm
call internal_norm_1D_${ri}$(sze, a, nrm, norm_request)
call linalg_error_handling(err_,err)
end subroutine norm_${rank}$D_${ii}$_${ri}$
#:endfor
!====================================================================
! Norms : any rank to rank-1, with DIM specifier and ${ii}$ input
!====================================================================
#:for rank in range(2, MAXRANK + 1)
! Pure function interface with DIM specifier. On error, the code will stop
pure module function stdlib_linalg_norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$(a, order, dim) result(nrm)
!> Input matrix a[..]
${rt}$, intent(in), target :: a${ranksuffix(rank)}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> Dimension to collapse by computing the norm w.r.t other dimensions
integer(ilp), intent(in) :: dim
!> Norm of the matrix.
real(${rk}$) :: nrm${reduced_shape('a', rank, 'dim')}$
call norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$(a, nrm, order, dim)
end function stdlib_linalg_norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$
! Function interface with DIM specifier and output error state.
module function stdlib_linalg_norm_${rank}$D_to_${rank-1}$D_err_${ii}$_${ri}$(a, order, dim, err) result(nrm)
!> Input matrix a[..]
${rt}$, intent(in), target :: a${ranksuffix(rank)}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> Dimension to collapse by computing the norm w.r.t other dimensions
integer(ilp), intent(in) :: dim
!> Output state return flag.
type(linalg_state_type), intent(out) :: err
!> Norm of the matrix.
real(${rk}$) :: nrm${reduced_shape('a', rank, 'dim')}$
call norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$(a, nrm, order, dim, err)
end function stdlib_linalg_norm_${rank}$D_to_${rank-1}$D_err_${ii}$_${ri}$
! Internal implementation
pure module subroutine norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$(a, nrm, order, dim, err)
!> Input matrix a[..]
${rt}$, intent(in) :: a${ranksuffix(rank)}$
!> Dimension to collapse by computing the norm w.r.t other dimensions
! (dim must be defined before it is used for `nrm`)
integer(ilp), intent(in) :: dim
!> Norm of the matrix.
real(${rk}$), intent(out) :: nrm${reduced_shape('a', rank, 'dim')}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out), optional :: err
type(linalg_state_type) :: err_
integer(ilp) :: sze,lda,norm_request,${loop_variables('j',rank-1,1)}$
logical :: contiguous_data
integer(ilp), dimension(${rank}$) :: spe,spack,perm,iperm
integer(ilp), dimension(${rank}$), parameter :: dim_range = [(lda,lda=1_ilp,${rank}$_ilp)]
${rt}$, allocatable :: apack${ranksuffix(rank)}$
! Input matrix properties
sze = size (a,kind=ilp)
spe = shape(a,kind=ilp)
! Initialize norm to zero
nrm = 0.0_${rk}$
if (sze<=0) then
err_ = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix shape: a=',shape(a,kind=ilp))
call linalg_error_handling(err_,err)
return
end if
! Check dimension choice
if (dim<1 .or. dim>${rank}$) then
err_ = linalg_state_type(this,LINALG_VALUE_ERROR,'dimension ',dim, &
'is out of rank for shape(a)=',shape(a,kind=ilp))
call linalg_error_handling(err_,err)
return
end if
! Check norm request
call parse_norm_type(order,norm_request,err_)
if (err_%error()) then
call linalg_error_handling(err_,err)
return
endif
! The norm's leading dimension
lda = spe(dim)
! Check if input column data is contiguous
contiguous_data = dim==1
! Get packed data with the norm dimension as the first dimension
if (.not.contiguous_data) then
! Permute array to map dim to 1
perm = [dim,pack(dim_range,dim_range/=dim)]
iperm(perm) = dim_range
spack = spe(perm)
apack = reshape(a, shape=spack, order=iperm)
${loop_variables_start('j', 'apack', rank-1, 1," "*12)}$
call internal_norm_1D_${ri}$(lda, apack(:, ${loop_variables('j',rank-1,1)}$), &
nrm(${loop_variables('j',rank-1,1)}$), norm_request)
${loop_variables_end(rank-1," "*12)}$
else
${loop_variables_start('j', 'a', rank-1, 1," "*12)}$
call internal_norm_1D_${ri}$(lda, a(:, ${loop_variables('j',rank-1,1)}$), &
nrm(${loop_variables('j',rank-1,1)}$), norm_request)
${loop_variables_end(rank-1," "*12)}$
endif
end subroutine norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$
#:endfor
!====================================================================
! Matrix norms
!====================================================================
! Internal implementation
module function matrix_norm_${ii}$_${ri}$(a, order, err) result(nrm)
!> Input matrix a(m,n)
${rt}$, intent(in), target :: a(:,:)
!> Norm of the matrix.
real(${rk}$) :: nrm
!> Order of the matrix norm being computed.
${it}$, #{if 'integer' in it}#optional, #{endif}#intent(in) :: order
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out), optional :: err
type(linalg_state_type) :: err_
integer(ilp) :: m,n
character :: mat_task
real(${rk}$), target :: work1(1)
real(${rk}$), pointer :: work(:)
m = size(a,dim=1,kind=ilp)
n = size(a,dim=2,kind=ilp)
! Initialize norm to zero
nrm = 0.0_${rk}$
if (m<=0 .or. n<=0) then
err_ = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix shape: a=',[m,n])
call linalg_error_handling(err_,err)
return
end if
! Check norm request: user + *LANGE support
call mat_task_request(order,mat_task,err_)
if (err_%error()) then
call linalg_error_handling(err_,err)
return
endif
if (mat_task==MAT_NORM_INF) then
allocate(work(m))
else
work => work1
end if
if (mat_task==MAT_NORM_SVD) then
nrm = maxval(svdvals(a,err_),1)
call linalg_error_handling(err_,err)
else
! LAPACK interface
nrm = lange(mat_task,m,n,a,m,work)
end if
if (mat_task==MAT_NORM_INF) deallocate(work)
end function matrix_norm_${ii}$_${ri}$
#:for rank in range(3, MAXRANK + 1)
! Pure function interface with DIM specifier. On error, the code will stop
module function matrix_norm_${rank}$D_to_${rank-2}$D_${ii}$_${ri}$(a, order, dim, err) result(nrm)
!> Input matrix a(m,n)
${rt}$, intent(in), contiguous, target :: a${ranksuffix(rank)}$
!> Norm of the matrix.
real(${rk}$), allocatable :: nrm${ranksuffix(rank-2)}$
!> Order of the matrix norm being computed.
${it}$, #{if 'integer' in it}#optional, #{endif}#intent(in) :: order
!> [optional] dimensions of the sub-matrices the norms should be evaluated at (default = [1,2])
integer(ilp), optional, intent(in) :: dim(2)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out), optional :: err
type(linalg_state_type) :: err_
integer(ilp) :: m,n,lda,dims(2),svd_errors
integer(ilp), dimension(${rank}$) :: s,spack,perm,iperm
integer(ilp), dimension(${rank}$), parameter :: dim_range = [(m,m=1_ilp,${rank}$_ilp)]
integer(ilp) :: ${loop_variables('j',rank-2,2)}$
logical :: contiguous_data
character :: mat_task
real(${rk}$), target :: work1(1)
real(${rk}$), pointer :: work(:)
${rt}$, pointer :: apack${ranksuffix(rank)}$
! Get dimensions
if (present(dim)) then
dims = dim
else
dims = [1,2]
endif
nullify(apack)
svd_errors = 0
if (dims(1)==dims(2) .or. .not.all(dims>0 .and. dims<=${rank}$)) then
err_ = linalg_state_type(this,LINALG_VALUE_ERROR,'Rank-',${rank}$,' matrix norm has invalid dim=',dims)
allocate(nrm${emptyranksuffix(rank-2)}$)
call linalg_error_handling(err_,err)
return
endif
! Check norm request: user + *LANGE support
call mat_task_request(order,mat_task,err_)
if (err_%error()) then
allocate(nrm${emptyranksuffix(rank-2)}$)
call linalg_error_handling(err_,err)
return
endif
! Input matrix properties
s = shape(a,kind=ilp)
! Check if input column data is contiguous
contiguous_data = all(dims==[1,2])
! Matrix norm size
m = s(dims(1))
n = s(dims(2))
if (m<=0 .or. n<=0) then
err_ = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix shape: a=',[m,n])
allocate(nrm${emptyranksuffix(rank-2)}$)
call linalg_error_handling(err_,err)
return
end if
! Get packed data with norm dimensions as 1:2
if (contiguous_data) then
! Reshape without moving data
spack = s
apack => a
else
! Dimension permutations to map dims(1),dims(2) => 1:2
perm = [dims,pack(dim_range, dim_range/=dims(1) .and. dim_range/=dims(2))]
iperm(perm) = dim_range
spack = s(perm)
allocate(apack,source=reshape(a, shape=spack, order=iperm))
endif
if (mat_task==MAT_NORM_INF) then
allocate(work(m))
elseif (mat_task==MAT_NORM_SVD) then
allocate(work(min(m,n)))
else
work => work1
endif
! Allocate norm
allocate(nrm${shape_from_array_size('apack',rank-2, 2)}$)
lda = size(apack,dim=1,kind=ilp)
! LAPACK interface
${loop_variables_start('j', 'apack', rank-2, 2)}$
if (mat_task==MAT_NORM_SVD) then
work(:) = svdvals(apack(:,:,${loop_variables('j',rank-2,2)}$),err_)
nrm(${loop_variables('j',rank-2,2)}$) = maxval(work,1)
if (err_%error()) svd_errors = svd_errors+1
else
nrm(${loop_variables('j',rank-2,2)}$) = &
lange(mat_task,m,n,apack(:,:,${loop_variables('j',rank-2,2)}$),lda,work)
end if
${loop_variables_end(rank-2)}$
if (any(mat_task==[MAT_NORM_INF,MAT_NORM_SVD])) deallocate(work)
if (.not.contiguous_data) deallocate(apack)
if (svd_errors>0) then
err_ = linalg_state_type(this,LINALG_VALUE_ERROR,svd_errors,'failed SVDs')
call linalg_error_handling(err_,err)
endif
end function matrix_norm_${rank}$D_to_${rank-2}$D_${ii}$_${ri}$
#:endfor
#:endfor
#:endfor
end submodule stdlib_linalg_norms
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_least_squares.fypp 0000664 0001750 0001750 00000055346 15135654166 026702 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set RHS_SUFFIX = ["one","many"]
#:set RHS_SYMBOL = [ranksuffix(r) for r in [1,2]]
#:set RHS_EMPTY = [emptyranksuffix(r) for r in [1,2]]
#:set ALL_RHS = list(zip(RHS_SYMBOL,RHS_SUFFIX,RHS_EMPTY))
submodule (stdlib_linalg) stdlib_linalg_least_squares
!! Least-squares solution to Ax=b
use stdlib_linalg_constants
use stdlib_linalg_lapack, only: gelsd, gglse, stdlib_ilaenv
use stdlib_linalg_lapack_aux, only: handle_gelsd_info, handle_gglse_info
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
implicit none
character(*), parameter :: this = 'lstsq'
contains
#:for rk,rt,ri in RC_KINDS_TYPES
! Workspace needed by gelsd
elemental subroutine ${ri}$gelsd_space(m,n,nrhs,lrwork,liwork,lcwork)
integer(ilp), intent(in) :: m,n,nrhs
integer(ilp), intent(out) :: lrwork,liwork,lcwork
integer(ilp) :: smlsiz,mnmin,nlvl
mnmin = min(m,n)
! Maximum size of the subproblems at the bottom of the computation (~25)
smlsiz = stdlib_ilaenv(9,'${ri}$gelsd',' ',0,0,0,0)
! The exact minimum amount of workspace needed depends on M, N and NRHS.
nlvl = max(0, ilog2(mnmin/(smlsiz+1))+1)
! Real space
#:if rt.startswith('complex')
lrwork = 10*mnmin+2*mnmin*smlsiz+8*mnmin*nlvl+3*smlsiz*nrhs+max((smlsiz+1)**2,n*(1+nrhs)+2*nrhs)
#:else
lrwork = 12*mnmin+2*mnmin*smlsiz+8*mnmin*nlvl+mnmin*nrhs+(smlsiz+1)**2
#:endif
lrwork = max(1,lrwork)
! Complex space
lcwork = 2*mnmin + nrhs*mnmin
! Integer space
liwork = max(1, 3*mnmin*nlvl+11*mnmin)
! For good performance, the workspace should generally be larger.
! Allocate 25% more space than strictly needed.
lrwork = ceiling(1.25*lrwork,kind=ilp)
lcwork = ceiling(1.25*lcwork,kind=ilp)
liwork = ceiling(1.25*liwork,kind=ilp)
end subroutine ${ri}$gelsd_space
#:endfor
#:for nd,ndsuf,nde in ALL_RHS
#:for rk,rt,ri in RC_KINDS_TYPES
! Compute the integer, real, [complex] working space requested by the least squares procedure
pure module subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$(a,b,lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> Right hand side vector or array, b[m] or b[m,nrhs]
${rt}$, intent(in) :: b${nd}$
!> Size of the working space arrays
integer(ilp), intent(out) :: lrwork,liwork
integer(ilp) #{if rt.startswith('c')}#, intent(out)#{endif}# :: lcwork
integer(ilp) :: m,n,nrhs
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
nrhs = size(b,kind=ilp)/size(b,1,kind=ilp)
call ${ri}$gelsd_space(m,n,nrhs,lrwork,liwork,lcwork)
end subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$
! Compute the least-squares solution to a real system of linear equations Ax = b
module function stdlib_linalg_${ri}$_lstsq_${ndsuf}$(a,b,cond,overwrite_a,rank,err) result(x)
!!### Summary
!! Compute least-squares solution to a real system of linear equations \( Ax = b \)
!!
!!### Description
!!
!! This function computes the least-squares solution of a linear matrix problem.
!!
!! param: a Input matrix of size [m,n].
!! param: b Right-hand-side vector of size [m] or matrix of size [m,nrhs].
!! param: cond [optional] Real input threshold indicating that singular values `s_i <= cond*maxval(s)`
!! do not contribute to the matrix rank.
!! param: overwrite_a [optional] Flag indicating if the input matrix can be overwritten.
!! param: rank [optional] integer flag returning matrix rank.
!! param: err [optional] State return flag.
!! return: x Solution vector of size [n] or solution matrix of size [n,nrhs].
!!
!> Input matrix a[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> Right hand side vector or array, b[m] or b[m,nrhs]
${rt}$, intent(in) :: b${nd}$
!> [optional] cutoff for rank evaluation: singular values s(i)<=cond*maxval(s) are considered 0.
real(${rk}$), optional, intent(in) :: cond
!> [optional] Can A,b data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Return rank of A
integer(ilp), optional, intent(out) :: rank
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, allocatable, target :: x${nd}$
integer(ilp) :: n,nrhs,ldb
n = size(a,2,kind=ilp)
ldb = size(b,1,kind=ilp)
nrhs = size(b,kind=ilp)/ldb
! Initialize solution with the shape of the rhs
#:if ndsuf=="one"
allocate(x(n))
#:else
allocate(x(n,nrhs))
#:endif
call stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$(a,b,x,&
cond=cond,overwrite_a=overwrite_a,rank=rank,err=err)
end function stdlib_linalg_${ri}$_lstsq_${ndsuf}$
! Compute the least-squares solution to a real system of linear equations Ax = b
module subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$(a,b,x,real_storage,int_storage, &
#{if rt.startswith('c')}#cmpl_storage,#{endif}# cond,singvals,overwrite_a,rank,err)
!!### Summary
!! Compute least-squares solution to a real system of linear equations \( Ax = b \)
!!
!!### Description
!!
!! This function computes the least-squares solution of a linear matrix problem.
!!
!! param: a Input matrix of size [m,n].
!! param: b Right-hand-side vector of size [n] or matrix of size [n,nrhs].
!! param: x Solution vector of size at [>=n] or solution matrix of size [>=n,nrhs].
!! param: real_storage [optional] Real working space
!! param: int_storage [optional] Integer working space
#:if rt.startswith('c')
!! param: cmpl_storage [optional] Complex working space
#:endif
!! param: cond [optional] Real input threshold indicating that singular values `s_i <= cond*maxval(s)`
!! do not contribute to the matrix rank.
!! param: singvals [optional] Real array of size [min(m,n)] returning a list of singular values.
!! param: overwrite_a [optional] Flag indicating if the input matrix can be overwritten.
!! param: rank [optional] integer flag returning matrix rank.
!! param: err [optional] State return flag.
!!
!> Input matrix a[n,n]
${rt}$, intent(inout), target :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, intent(inout), contiguous, target :: x${nd}$
!> [optional] real working storage space
real(${rk}$), optional, intent(inout), target :: real_storage(:)
!> [optional] integer working storage space
integer(ilp), optional, intent(inout), target :: int_storage(:)
#:if rt.startswith('c')
!> [optional] complex working storage space
${rt}$, optional, intent(inout), target :: cmpl_storage(:)
#:endif
!> [optional] cutoff for rank evaluation: singular values s(i)<=cond*maxval(s) are considered 0.
real(${rk}$), optional, intent(in) :: cond
!> [optional] list of singular values [min(m,n)], in descending magnitude order, returned by the SVD
real(${rk}$), optional, intent(out), target :: singvals(:)
!> [optional] Can A,b data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Return rank of A
integer(ilp), optional, intent(out) :: rank
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!! Local variables
type(linalg_state_type) :: err0
integer(ilp) :: m,n,lda,ldb,nrhs,ldx,nrhsx,info,mnmin,mnmax,arank,lrwork,liwork,lcwork
integer(ilp) :: nrs,nis,nsvd
#:if rt.startswith('complex')
integer(ilp) :: ncs
#:endif
integer(ilp), pointer :: iwork(:)
logical(lk) :: copy_a,large_enough_x
real(${rk}$) :: acond,rcond
real(${rk}$), pointer :: rwork(:),singular(:)
${rt}$, pointer :: xmat(:,:),amat(:,:)
#:if rt.startswith('complex')
${rt}$, pointer :: cwork(:)
#:endif
! Problem sizes
m = size(a,1,kind=ilp)
lda = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
ldb = size(b,1,kind=ilp)
nrhs = size(b ,kind=ilp)/ldb
ldx = size(x,1,kind=ilp)
nrhsx = size(x ,kind=ilp)/ldx
mnmin = min(m,n)
mnmax = max(m,n)
if (lda<1 .or. n<1 .or. ldb<1 .or. ldb/=m .or. ldx cmpl_storage
else
allocate(cwork(lcwork))
endif
ncs = size(cwork,kind=ilp)
#:endif
if (nrs=',lrwork, &
', int=',nis,' should be >=',liwork, &
#{if rt.startswith('complex')}#', cmplx=',ncs,' should be >=',lcwork, &#{endif}#
', singv=',nsvd,' should be >=',mnmin)
else
! Solve system using singular value decomposition
call gelsd(m,n,nrhs,amat,lda,xmat,ldb,singular,rcond,arank, &
#:if rt.startswith('complex')
cwork,ncs,rwork,iwork,info)
#:else
rwork,nrs,iwork,info)
#:endif
! The condition number of A in the 2-norm = S(1)/S(min(m,n)).
acond = singular(1)/singular(mnmin)
! Process output
call handle_gelsd_info(this,info,lda,n,ldb,nrhs,err0)
endif
! Process output and return
if (.not.large_enough_x) then
#:if ndsuf=="one"
x(1:n) = xmat(1:n,1)
#:else
x(1:n,1:nrhs) = xmat(1:n,1:nrhs)
#:endif
deallocate(xmat)
endif
if (copy_a) deallocate(amat)
if (present(rank)) rank = arank
if (.not.present(real_storage)) deallocate(rwork)
if (.not.present(int_storage)) deallocate(iwork)
#:if rt.startswith('complex')
if (.not.present(cmpl_storage)) deallocate(cwork)
#:endif
if (.not.present(singvals)) deallocate(singular)
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$
#:endfor
#:endfor
! Simple integer log2 implementation
elemental integer(ilp) function ilog2(x)
integer(ilp), intent(in) :: x
integer(ilp) :: remndr
if (x>0) then
remndr = x
ilog2 = -1_ilp
do while (remndr>0)
ilog2 = ilog2 + 1_ilp
remndr = shiftr(remndr,1)
end do
else
ilog2 = -huge(0_ilp)
endif
end function ilog2
!-------------------------------------------------------------
!----- Equality-constrained Least-Squares solver -----
!-------------------------------------------------------------
pure subroutine check_problem_size(ma, na, mb, mc, nc, md, mx, err)
integer(ilp), intent(in) :: ma, na, mb, mc, nc, md, mx
type(linalg_state_type), intent(out) :: err
! Check sizes.
if (ma < 1 .or. na < 1) then
err = linalg_state_type(this, LINALG_VALUE_ERROR, 'Invalid matrix size a(m, n) =', [ma, na])
return
else if (mc < 1 .or. nc < 1) then
err = linalg_state_type(this, LINALG_VALUE_ERROR, 'Invalid matrix size c(p, n) =', [mc, nc])
else if (na /= nc) then
err = linalg_state_type(this, LINALG_VALUE_ERROR, 'Matrix A and matrix C have inconsistent number of columns.')
else if (mb /= ma) then
err = linalg_state_type(this, LINALG_VALUE_ERROR, 'Size(b) inconsistent with number of rows in a, size(b) =', mb)
else if (md /= mc) then
err = linalg_state_type(this, LINALG_VALUE_ERROR, 'Size(d) inconsistent with number of rows in c, size(d) =', md)
else if (na /= mx) then
err = linalg_state_type(this, LINALG_VALUE_ERROR, 'Size(x) inconsistent with number of columns of a, size(x) =', mx)
endif
end subroutine check_problem_size
#:for rk, rt, ri in RC_KINDS_TYPES
! Compute the size of the workspace requested by the constrained least-squares procedure.
module subroutine stdlib_linalg_${ri}$_constrained_lstsq_space(A, C, lwork, err)
!> Least-squares cost.
${rt}$, intent(in) :: A(:, :)
!> Equality constraints.
${rt}$, intent(in) :: C(:, :)
!> Size of the workspace array.
integer(ilp), intent(out) :: lwork
!> [optional] State return flag.
type(linalg_state_type), optional, intent(out) :: err
!> Local variables.
integer(ilp) :: m, n, p, info
${rt}$ :: a_dummy(1, 1), b_dummy(1)
${rt}$ :: c_dummy(1, 1), d_dummy(1)
${rt}$ :: work(1), x(1)
type(linalg_state_type) :: err0
!> Problem dimensions.
m = size(A, 1) ; n = size(A, 2) ; p = size(C, 1)
lwork = -1_ilp
!> Workspace query.
call gglse(m, n, p, a_dummy, m, c_dummy, p, b_dummy, d_dummy, x, work, lwork, info)
call handle_gglse_info(this, info, m, n, p, err0)
!> Optimal workspace size.
lwork = ceiling(real(work(1), kind=${rk}$), kind=ilp)
call linalg_error_handling(err0, err)
end subroutine stdlib_linalg_${ri}$_constrained_lstsq_space
! Constrained least-squares solver.
module subroutine stdlib_linalg_${ri}$_solve_constrained_lstsq(A, b, C, d, x, storage, overwrite_matrices, err)
!! ### Summary
!! Compute the solution of the equality constrained least-squares problem
!!
!! minimize || Ax - b ||²
!! subject to Cx = d
!!
!! ### Description
!!
!! This function computes the solution of an equality constrained linear least-squares
!! problem.
!!
!! param: a Input matrix of size [m, n] (with m > n).
!! param: b Right-hand side vector of size [m] in the least-squares cost.
!! param: c Input matrix of size [p, n] (with p < n) defining the equality constraints.
!! param: d Right-hand side vector of size [p] in the equality constraints.
!! param: x Vector of size [n] solution to the problem.
!! param: storage [optional] Working array.
!! param: overwrite_matrices [optional] Boolean flag indicating whether the matrices
!! and vectors can be overwritten.
!! param: err [optional] State return flag.
!!
!> Least-squares cost.
${rt}$, intent(inout), target :: A(:, :), b(:)
!> Equality constraints.
${rt}$, intent(inout), target :: C(:, :), d(:)
!> Solution vector.
${rt}$, intent(out) :: x(:)
!> [optional] Storage.
${rt}$, optional, intent(out), target :: storage(:)
!> [optional] Can A, b, C, and d be overwritten?
logical(lk), optional, intent(in) :: overwrite_matrices
!> [optional] State return flag.
type(linalg_state_type), optional, intent(out) :: err
! Local variables.
type(linalg_state_type) :: err0
integer(ilp) :: ma, na, mb
integer(ilp) :: mc, nc, md
integer(ilp) :: mx
logical(lk) :: overwrite_matrices_
${rt}$, pointer :: amat(:, :), bvec(:)
${rt}$, pointer :: cmat(:, :), dvec(:)
! LAPACK related.
integer(ilp) :: lwork, info
${rt}$, pointer :: work(:)
!> Check dimensions.
ma = size(A, 1, kind=ilp) ; na = size(A, 2, kind=ilp)
mc = size(C, 1, kind=ilp) ; nc = size(C, 2, kind=ilp)
mb = size(b, kind=ilp) ; md = size(d, kind=ilp) ; mx = size(x, kind=ilp)
call check_problem_size(ma, na, mb, mc, nc, md, mx, err0)
if (err0%error()) then
call linalg_error_handling(err0, err)
return
endif
!> Check if matrices can be overwritten.
overwrite_matrices_ = optval(overwrite_matrices, .false._lk)
!> Allocate matrices.
if (overwrite_matrices_) then
amat => a
bvec => b
cmat => c
dvec => d
else
allocate(amat(ma, na), source=a)
allocate(bvec(mb), source=b)
allocate(cmat(mc, nc), source=c)
allocate(dvec(md), source=d)
endif
!> Retrieve workspace size.
call stdlib_linalg_${ri}$_constrained_lstsq_space(A, C, lwork, err0)
if (err0%ok()) then
!> Workspace.
if (present(storage)) then
work => storage
else
allocate(work(lwork))
endif
if (size(work, kind=ilp) < lwork) then
err0 = linalg_state_type(this, LINALG_ERROR, 'Insufficient workspace. Should be at least ', lwork)
call linalg_error_handling(err0, err)
return
endif
!> Compute constrained lstsq solution.
call gglse(ma, na, mc, amat, ma, cmat, mc, bvec, dvec, x, work, lwork, info)
call handle_gglse_info(this, info, ma, na, mc, err0)
!> Deallocate.
if (.not. present(storage)) deallocate(work)
endif
if (.not. overwrite_matrices_) then
deallocate(amat, bvec, cmat, dvec)
endif
call linalg_error_handling(err0, err)
end subroutine stdlib_linalg_${ri}$_solve_constrained_lstsq
module function stdlib_linalg_${ri}$_constrained_lstsq(A, b, C, d, overwrite_matrices, err) result(x)
!! ### Summary
!! Compute the solution of the equality constrained least-squares problem
!!
!! minimize || Ax - b ||²
!! subject to Cx = d
!!
!! ### Description
!!
!! This function computes the solution of an equality constrained linear least-squares
!! problem.
!!
!! param: a Input matrix of size [m, n] (with m > n).
!! param: b Right-hand side vector of size [m] in the least-squares cost.
!! param: c Input matrix of size [p, n] (with p < n) defining the equality constraints.
!! param: d Right-hand side vector of size [p] in the equality constraints.
!! param: x Vector of size [n] solution to the problem.
!! param: overwrite_matrices [optional] Boolean flag indicating whether the matrices
!! and vectors can be overwritten.
!! param: err [optional] State return flag.
!!
!> Least-squares cost.
${rt}$, intent(inout), target :: A(:, :), b(:)
!> Equality constraints.
${rt}$, intent(inout), target :: C(:, :), d(:)
!> [optional] Can A, b, C, d be overwritten?
logical(lk), optional, intent(in) :: overwrite_matrices
!> [optional] State return flag.
type(linalg_state_type), optional, intent(out) :: err
!> Solution of the constrained least-squares problem.
${rt}$, allocatable, target :: x(:)
! Local variables.
integer(ilp) :: n
n = size(A, 2, kind=ilp)
allocate(x(n))
call stdlib_linalg_${ri}$_solve_constrained_lstsq(A, b, C, d, x, overwrite_matrices=overwrite_matrices, err=err)
end function stdlib_linalg_${ri}$_constrained_lstsq
#:endfor
end submodule stdlib_linalg_least_squares
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_schur.fypp 0000664 0001750 0001750 00000030070 15135654166 025136 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_linalg) stdlib_linalg_schur
use stdlib_linalg_constants
use stdlib_linalg_lapack, only: gees
use stdlib_linalg_lapack_aux, only: handle_gees_info
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
implicit none
character(*), parameter :: this = 'schur'
!> List of internal GEES tasks:
!> No task request
character, parameter :: GEES_NOT = 'N'
!> Request Schur vectors to be computed
character, parameter :: GEES_WITH_VECTORS = 'V'
!> Request Schur vectors to be sorted
character, parameter :: GEES_SORTED_VECTORS = 'S'
contains
!> Wrapper function for Schur vectors request
elemental character function gees_vectors(wanted)
!> Are Schur vectors wanted?
logical(lk), intent(in) :: wanted
gees_vectors = merge(GEES_WITH_VECTORS,GEES_NOT,wanted)
end function gees_vectors
!> Wrapper function for Schur vectors request
elemental character function gees_sort_eigs(sorted)
!> Should the eigenvalues be sorted?
logical(lk), intent(in) :: sorted
gees_sort_eigs = merge(GEES_SORTED_VECTORS,GEES_NOT,sorted)
end function gees_sort_eigs
#:for rk, rt, ri in RC_KINDS_TYPES
!> Workspace query
module subroutine get_schur_${ri}$_workspace(a,lwork,err)
!> Input matrix a[m,m]
${rt}$, intent(in), target :: a(:,:)
!> Minimum workspace size for the decomposition operation
integer(ilp), intent(out) :: lwork
!> State return flag. Returns an error if the query failed
type(linalg_state_type), optional, intent(out) :: err
integer(ilp) :: m,n,sdim,info
character :: jobvs,sort
logical(lk) :: bwork_dummy(1)
${rt}$, pointer :: amat(:,:)
real(${rk}$) :: rwork_dummy(1)
${rt}$ :: wr_dummy(1),wi_dummy(1),vs_dummy(1,1),work_dummy(1)
type(linalg_state_type) :: err0
!> Initialize problem
lwork = -1_ilp
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
!> Create a dummy intent(inout) argument
amat => a
!> Select dummy task
jobvs = gees_vectors(.true.)
sort = gees_sort_eigs(.false.)
sdim = 0_ilp
!> Get Schur workspace
call gees(jobvs,sort,do_not_select,n,amat,m,sdim,wr_dummy,#{if rt.startswith('r')}#wi_dummy, #{endif}#&
vs_dummy,m,work_dummy,lwork,#{if rt.startswith('c')}#rwork_dummy,#{endif}#bwork_dummy,info)
if (info==0) lwork = nint(real(work_dummy(1),kind=${rk}$),kind=ilp)
call handle_gees_info(this,info,m,n,m,err0)
call linalg_error_handling(err0,err)
contains
! Interface to dummy select routine
pure logical(lk) function do_not_select(alpha#{if rt.startswith('r')}#r,alphai#{endif}#)
${rt}$, intent(in) :: alpha#{if rt.startswith('r')}#r,alphai#{endif}#
do_not_select = .false.
end function do_not_select
end subroutine get_schur_${ri}$_workspace
! Schur decomposition subroutine
module subroutine stdlib_linalg_${ri}$_schur(a,t,z,eigvals,overwrite_a,storage,err)
!> Input matrix a[m,m]
${rt}$, intent(inout), target :: a(:,:)
!> Schur form of A: upper-triangular or quasi-upper-triangular matrix T
${rt}$, intent(out), contiguous, target :: t(:,:)
!> Unitary/orthonormal transformation matrix Z
${rt}$, optional, intent(out), contiguous, target :: z(:,:)
!> [optional] Output eigenvalues that appear on the diagonal of T
complex(${rk}$), optional, intent(out), contiguous, target :: eigvals(:)
!> [optional] Provide pre-allocated workspace, size to be checked with schur_space
${rt}$, optional, intent(inout), target :: storage(:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] State return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
! Local variables
integer(ilp) :: m,n,mt,nt,ldvs,nvs,lde,lwork,sdim,info
logical(lk) :: overwrite_a_
logical(lk), target :: bwork_dummy(1),local_eigs
logical(lk), pointer :: bwork(:)
real(${rk}$), allocatable :: rwork(:)
${rt}$, target :: vs_dummy(1,1)
${rt}$, pointer :: vs(:,:),work(:),eigs(:)#{if rt.startswith('r')}#,eigi(:)#{endif}#
character :: jobvs,sort
type(linalg_state_type) :: err0
! Problem size
m = size(a, 1, kind=ilp)
n = size(a, 2, kind=ilp)
mt = size(t, 1, kind=ilp)
nt = size(t, 2, kind=ilp)
! Validate dimensions
if (m/=n .or. m<=0 .or. n<=0) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, 'Matrix A must be square: size(a)=',[m,n])
call linalg_error_handling(err0, err)
return
end if
if (mt/=nt .or. mt/=n .or. nt/=n) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, 'Matrix T must be square: size(T)=',[mt,nt], &
'should be',[m,n])
call linalg_error_handling(err0, err)
return
end if
!> Copy data into the output array
t = a
! Can A be overwritten? By default, do not overwrite
overwrite_a_ = .false._lk
if (present(overwrite_a)) overwrite_a_ = overwrite_a .and. n>=2
!> Schur vectors
jobvs = gees_vectors(present(z))
if (present(z)) then
vs => z
ldvs = size(vs, 1, kind=ilp)
nvs = size(vs, 2, kind=ilp)
if (ldvs eigvals
local_eigs = .false.
#:else
local_eigs = .true.
#:endif
else
local_eigs = .true.
lde = n
end if
if (local_eigs) then
! Use A storage if possible
if (overwrite_a_) then
eigs => a(:,1)
#:if rt.startswith('r')
eigi => a(:,2)
#:endif
else
allocate(eigs(n)#{if rt.startswith('r')}#,eigi(n)#{endif}#)
end if
endif
#:if rt.startswith('c')
allocate(rwork(n))
#:endif
if (lde=',n)
else
! Compute Schur decomposition
call gees(jobvs,sort,eig_select,nt,t,mt,sdim,eigs,#{if rt.startswith('r')}#eigi,#{endif}# &
vs,ldvs,work,lwork,#{if rt.startswith('c')}#rwork,#{endif}#bwork,info)
call handle_gees_info(this,info,m,n,m,err0)
end if
eigenvalue_output: if (local_eigs) then
#:if rt.startswith('r')
! Build complex eigenvalues
if (present(eigvals)) eigvals = cmplx(eigs,eigi,kind=${rk}$)
#:endif
if (.not.overwrite_a_) deallocate(eigs#{if rt.startswith('r')}#,eigi#{endif}#)
endif eigenvalue_output
if (.not.present(storage)) deallocate(work)
if (sort/=GEES_NOT) deallocate(bwork)
call linalg_error_handling(err0,err)
contains
! Dummy select routine: currently, no sorting options are offered
pure logical(lk) function eig_select(alpha#{if rt.startswith('r')}#r,alphai#{endif}#)
#:if rt.startswith('r')
${rt}$, intent(in) :: alphar,alphai
complex(${rk}$) :: alpha
alpha = cmplx(alphar,alphai,kind=${rk}$)
#:else
${rt}$, intent(in) :: alpha
#:endif
eig_select = .false.
end function eig_select
end subroutine stdlib_linalg_${ri}$_schur
! Schur decomposition subroutine: real eigenvalue interface
module subroutine stdlib_linalg_real_eig_${ri}$_schur(a,t,z,eigvals,overwrite_a,storage,err)
!> Input matrix a[m,m]
${rt}$, intent(inout), target :: a(:,:)
!> Schur form of A: upper-triangular or quasi-upper-triangular matrix T
${rt}$, intent(out), contiguous, target :: t(:,:)
!> Unitary/orthonormal transformation matrix Z
${rt}$, optional, intent(out), contiguous, target :: z(:,:)
!> Output eigenvalues that appear on the diagonal of T
real(${rk}$), intent(out), contiguous, target :: eigvals(:)
!> [optional] Provide pre-allocated workspace, size to be checked with schur_space
${rt}$, optional, intent(inout), target :: storage(:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] State return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
type(linalg_state_type) :: err0
integer(ilp) :: n
complex(${rk}$), allocatable :: ceigvals(:)
real(${rk}$), parameter :: rtol = epsilon(0.0_${rk}$)
real(${rk}$), parameter :: atol = tiny(0.0_${rk}$)
n = size(eigvals,dim=1,kind=ilp)
allocate(ceigvals(n))
!> Compute Schur decomposition with complex eigenvalues
call stdlib_linalg_${ri}$_schur(a,t,z,ceigvals,overwrite_a,storage,err0)
! Check that no eigenvalues have meaningful imaginary part
if (err0%ok() .and. any(aimag(ceigvals)>atol+rtol*abs(abs(ceigvals)))) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR, &
'complex eigenvalues detected: max(imag(lambda))=',maxval(aimag(ceigvals)))
endif
! Return real components only
eigvals(:n) = real(ceigvals,kind=${rk}$)
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_real_eig_${ri}$_schur
#:endfor
end submodule stdlib_linalg_schur
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_determinant.fypp 0000664 0001750 0001750 00000016775 15135654166 026344 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_linalg) stdlib_linalg_determinant
!! Determinant of a rectangular matrix
use stdlib_linalg_constants
use stdlib_linalg_lapack, only: getrf
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
implicit none
! Function interface
character(*), parameter :: this = 'determinant'
contains
! BLAS/LAPACK backends do not currently support xdp
#:for rk,rt in RC_KINDS_TYPES
#:if rk!="xdp"
pure module function stdlib_linalg_pure_${rt[0]}$${rk}$determinant(a) result(det)
!!### Summary
!! Compute determinant of a real square matrix (pure interface).
!!
!!### Description
!!
!! This function computes the determinant of a real square matrix.
!!
!! param: a Input matrix of size [m,n].
!! return: det Matrix determinant.
!!
!!### Example
!!
!!```fortran
!!
!! ${rt}$ :: matrix(3,3)
!! ${rt}$ :: determinant
!! matrix = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!! determinant = det(matrix)
!!
!!```
!> Input matrix a[m,n]
${rt}$, intent(in) :: a(:,:)
!> Matrix determinant
${rt}$ :: det
!! Local variables
type(linalg_state_type) :: err0
integer(ilp) :: m,n,info,perm,k
integer(ilp), allocatable :: ipiv(:)
${rt}$, allocatable :: amat(:,:)
! Matrix determinant size
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
if (m/=n .or. .not.min(m,n)>=0) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid or non-square matrix: a=[',m,',',n,']')
det = 0.0_${rk}$
! Process output and return
call linalg_error_handling(err0)
return
end if
select case (m)
case (0)
! Empty array has determinant 1 because math
det = 1.0_${rk}$
case (1)
! Scalar input
det = a(1,1)
case default
! Find determinant from LU decomposition
! Initialize a matrix temporary
allocate(amat(m,n),source=a)
! Pivot indices
allocate(ipiv(n))
! Compute determinant from LU factorization, then calculate the
! product of all diagonal entries of the U factor.
call getrf(m,n,amat,m,ipiv,info)
select case (info)
case (0)
! Success: compute determinant
! Start with real 1.0
det = 1.0_${rk}$
perm = 0
do k=1,n
if (ipiv(k)/=k) perm = perm+1
det = det*amat(k,k)
end do
if (mod(perm,2)/=0) det = -det
case (:-1)
err0 = linalg_state_type(this,LINALG_ERROR,'invalid matrix size a=[',m,',',n,']')
case (1:)
err0 = linalg_state_type(this,LINALG_ERROR,'singular matrix')
case default
err0 = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
end select
deallocate(amat)
end select
! Process output and return
call linalg_error_handling(err0)
end function stdlib_linalg_pure_${rt[0]}$${rk}$determinant
module function stdlib_linalg_${rt[0]}$${rk}$determinant(a,overwrite_a,err) result(det)
!!### Summary
!! Compute determinant of a square matrix (with error control).
!!
!!### Description
!!
!! This function computes the determinant of a square matrix with error control.
!!
!! param: a Input matrix of size [m,n].
!! param: overwrite_a [optional] Flag indicating if the input matrix can be overwritten.
!! param: err State return flag.
!! return: det Matrix determinant.
!!
!!### Example
!!
!!```fortran
!!
!! ${rt}$ :: matrix(3,3)
!! ${rt}$ :: determinant
!! matrix = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!! determinant = det(matrix, err=err)
!!
!!```
!
!> Input matrix a[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> State return flag.
type(linalg_state_type), intent(out) :: err
!> Matrix determinant
${rt}$ :: det
!! Local variables
type(linalg_state_type) :: err0
integer(ilp) :: m,n,info,perm,k
integer(ilp), allocatable :: ipiv(:)
logical(lk) :: copy_a
${rt}$, pointer :: amat(:,:)
! Matrix determinant size
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
if (m/=n .or. .not.min(m,n)>=0) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid or non-square matrix: a=[',m,',',n,']')
det = 0.0_${rk}$
! Process output and return
call linalg_error_handling(err0,err)
return
end if
! Can A be overwritten? By default, do not overwrite
if (present(overwrite_a)) then
copy_a = .not.overwrite_a
else
copy_a = .true._lk
endif
select case (m)
case (0)
! Empty array has determinant 1 because math
det = 1.0_${rk}$
case (1)
! Scalar input
det = a(1,1)
case default
! Find determinant from LU decomposition
! Initialize a matrix temporary
if (copy_a) then
allocate(amat, source=a)
else
amat => a
endif
! Pivot indices
allocate(ipiv(n))
! Compute determinant from LU factorization, then calculate the
! product of all diagonal entries of the U factor.
call getrf(m,n,amat,m,ipiv,info)
select case (info)
case (0)
! Success: compute determinant
! Start with real 1.0
det = 1.0_${rk}$
perm = 0
do k=1,n
if (ipiv(k)/=k) perm = perm+1
det = det*amat(k,k)
end do
if (mod(perm,2)/=0) det = -det
case (:-1)
err0 = linalg_state_type(this,LINALG_ERROR,'invalid matrix size a=[',m,',',n,']')
case (1:)
err0 = linalg_state_type(this,LINALG_ERROR,'singular matrix')
case default
err0 = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
end select
if (copy_a) deallocate(amat)
end select
! Process output and return
call linalg_error_handling(err0,err)
end function stdlib_linalg_${rt[0]}$${rk}$determinant
#:endif
#:endfor
end submodule stdlib_linalg_determinant
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_qr.fypp 0000664 0001750 0001750 00000040445 15135654166 024443 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_linalg) stdlib_linalg_qr
use stdlib_linalg_constants
use stdlib_linalg_lapack, only: geqrf, geqp3, orgqr, ungqr
use stdlib_linalg_lapack_aux, only: handle_geqrf_info, handle_orgqr_info, handle_geqp3_info
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
implicit none
character(*), parameter :: this = 'qr'
contains
! Check problem size and evaluate whether full/reduced problem is requested
pure subroutine check_problem_size(m,n,q1,q2,r1,r2,err,reduced)
integer(ilp), intent(in) :: m,n,q1,q2,r1,r2
type(linalg_state_type), intent(out) :: err
logical, intent(out) :: reduced
integer(ilp) :: k
k = min(m,n)
reduced = .false.
! Check sizes
if (m<1 .or. n<1) then
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a(m,n)=',[m,n])
else
! Check if we should operate on reduced full QR
! - Reduced: shape(Q)==[m,k], shape(R)==[k,n]
! - Full : shape(Q)==[m,m], shape(R)==[m,n]
if (all([q1,q2]==[m,k] .and. [r1,r2]==[k,n])) then
reduced = .true.
elseif (all([q1,q2]==[m,m] .and. [r1,r2]==[m,n])) then
reduced = .false.
else
err = linalg_state_type(this,LINALG_VALUE_ERROR,'with a=',[m,n],'q=',[q1,q2],'r=',[r1,r2], &
'problem is neither full (q=',[m,m],'r=',[m,n],') nor reduced (q=',[m,m],'r=',[m,n],')')
endif
end if
end subroutine check_problem_size
#:for rk,rt,ri in RC_KINDS_TYPES
! Get workspace size for QR operations
pure module subroutine get_qr_${ri}$_workspace(a,lwork,err)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> Minimum workspace size for both operations
integer(ilp), intent(out) :: lwork
!> State return flag. Returns an error if the query failed
type(linalg_state_type), optional, intent(out) :: err
integer(ilp) :: m,n,k,info,lwork_qr,lwork_ord
${rt}$ :: work_dummy(1),tau_dummy(1),a_dummy(1,1)
type(linalg_state_type) :: err0
lwork = -1_ilp
!> Problem sizes
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
! QR space
lwork_qr = -1_ilp
call geqrf(m,n,a_dummy,m,tau_dummy,work_dummy,lwork_qr,info)
call handle_geqrf_info(this,info,m,n,lwork_qr,err0)
if (err0%error()) then
call linalg_error_handling(err0,err)
return
endif
lwork_qr = ceiling(real(work_dummy(1),kind=${rk}$),kind=ilp)
! Ordering space (for full factorization)
lwork_ord = -1_ilp
call #{if rt.startswith('complex')}# ungqr #{else}# orgqr #{endif}# &
(m,m,k,a_dummy,m,tau_dummy,work_dummy,lwork_ord,info)
call handle_orgqr_info(this,info,m,n,k,lwork_ord,err0)
if (err0%error()) then
call linalg_error_handling(err0,err)
return
endif
lwork_ord = ceiling(real(work_dummy(1),kind=${rk}$),kind=ilp)
! Pick the largest size, so two operations can be performed with the same allocation
lwork = max(lwork_qr, lwork_ord)
end subroutine get_qr_${ri}$_workspace
! Compute the solution to a real system of linear equations A * X = B
pure module subroutine stdlib_linalg_${ri}$_qr(a,q,r,overwrite_a,storage,err)
!> Input matrix a[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> Orthogonal matrix Q ([m,m], or [m,k] if reduced)
${rt}$, intent(out), contiguous, target :: q(:,:)
!> Upper triangular matrix R ([m,n], or [k,n] if reduced)
${rt}$, intent(out), contiguous, target :: r(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Provide pre-allocated workspace, size to be checked with qr_space
${rt}$, intent(out), optional, target :: storage(:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Local variables
type(linalg_state_type) :: err0
integer(ilp) :: i,j,m,n,k,q1,q2,r1,r2,lda,lwork,info
logical(lk) :: overwrite_a_,use_q_matrix,reduced
${rt}$ :: r11
${rt}$, parameter :: zero = 0.0_${rk}$
${rt}$, pointer :: amat(:,:),tau(:),work(:)
!> Problem sizes
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
q1 = size(q,1,kind=ilp)
q2 = size(q,2,kind=ilp)
r1 = size(r,1,kind=ilp)
r2 = size(r,2,kind=ilp)
! Check if we should operate on reduced full QR
call check_problem_size(m,n,q1,q2,r1,r2,err0,reduced)
if (err0%error()) then
call linalg_error_handling(err0,err)
return
end if
! Check if Q can be used as temporary storage for A,
! to be destroyed by *GEQRF
use_q_matrix = q1>=m .and. q2>=n
! Can A be overwritten? By default, do not overwrite
overwrite_a_ = .false._lk
if (present(overwrite_a) .and. .not.use_q_matrix) overwrite_a_ = overwrite_a
! Initialize a matrix temporary, or reuse available
! storage if possible
if (use_q_matrix) then
amat => q
q(:m,:n) = a
elseif (overwrite_a_) then
amat => a
else
allocate(amat(m,n),source=a)
endif
lda = size(amat,1,kind=ilp)
! To store the elementary reflectors, we need a [1:k] column.
if (.not.use_q_matrix) then
! Q is not being used as the storage matrix
tau(1:k) => q(1:k,1)
else
! R has unused contiguous storage in the 1st column, except for the
! diagonal element. So, use the full column and store it in a dummy variable
tau(1:k) => r(1:k,1)
endif
! Retrieve workspace size
call get_qr_${ri}$_workspace(a,lwork,err0)
if (err0%ok()) then
if (present(storage)) then
work => storage
else
allocate(work(lwork))
endif
if (.not.size(work,kind=ilp)>=lwork) then
err0 = linalg_state_type(this,LINALG_ERROR,'insufficient workspace: should be at least ',lwork)
call linalg_error_handling(err0,err)
return
endif
! Compute factorization.
call geqrf(m,n,amat,m,tau,work,lwork,info)
call handle_geqrf_info(this,info,m,n,lwork,err0)
if (err0%ok()) then
! Get R matrix out before overwritten.
! Do not copy the first column at this stage: it may be being used by `tau`
r11 = amat(1,1)
forall(i=1:min(r1,m),j=2:n) r(i,j) = merge(amat(i,j),zero,i<=j)
! Convert K elementary reflectors tau(1:k) -> orthogonal matrix Q
call #{if rt.startswith('complex')}# ungqr #{else}# orgqr #{endif}# &
(q1,q2,k,amat,lda,tau,work,lwork,info)
call handle_orgqr_info(this,info,m,n,k,lwork,err0)
! Copy result back to Q
if (.not.use_q_matrix) q = amat(:q1,:q2)
! Copy first column of R
r(1,1) = r11
r(2:r1,1) = zero
! Ensure last m-n rows of R are zeros,
! if full matrices were provided
if (.not.reduced) r(k+1:m,1:n) = zero
endif
if (.not.present(storage)) deallocate(work)
endif
if (.not.(use_q_matrix.or.overwrite_a_)) deallocate(amat)
! Process output and return
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_${ri}$_qr
#:endfor
!---------------------------------------------------------
!----- QR decomposition with column pivoting -----
!---------------------------------------------------------
#:for rk, rt, ri in RC_KINDS_TYPES
! Get workspace size for QR operations
pure module subroutine get_pivoting_qr_${ri}$_workspace(a,lwork,pivoting,err)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> Minimum workspace size for both operations
integer(ilp), intent(out) :: lwork
!> Pivoting flag.
logical(lk), intent(in) :: pivoting
!> State return flag. Returns an error if the query failed
type(linalg_state_type), optional, intent(out) :: err
integer(ilp) :: m,n,k,info,lwork_qr,lwork_ord
${rt}$ :: work_dummy(1),tau_dummy(1),a_dummy(1,1)
integer(ilp) :: jpvt_dummy(1)
real(${rk}$) :: rwork_dummy(1)
type(linalg_state_type) :: err0
if (pivoting) then
lwork = -1_ilp
!> Problem sizes
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
! QR space
lwork_qr = -1_ilp
#:if rt.startswith('complex')
call geqp3(m, n, a_dummy, m, jpvt_dummy, tau_dummy, work_dummy, lwork_qr, rwork_dummy, info)
#:else
call geqp3(m, n, a_dummy, m, jpvt_dummy, tau_dummy, work_dummy, lwork_qr, info)
#:endif
call handle_geqp3_info(this, info, m, n, lwork_qr, err0)
if (err0%error()) then
call linalg_error_handling(err0,err)
return
endif
lwork_qr = ceiling(real(work_dummy(1),kind=${rk}$),kind=ilp)
! Ordering space (for full factorization)
lwork_ord = -1_ilp
call #{if rt.startswith('complex')}# ungqr #{else}# orgqr #{endif}# &
(m,k,k,a_dummy,m,tau_dummy,work_dummy,lwork_ord,info)
call handle_orgqr_info(this,info,m,n,k,lwork_ord,err0)
if (err0%error()) then
call linalg_error_handling(err0,err)
return
endif
lwork_ord = ceiling(real(work_dummy(1),kind=${rk}$),kind=ilp)
! Pick the largest size, so two operations can be performed with the same allocation
lwork = max(lwork_qr, lwork_ord)
else
call qr_space(a, lwork, err)
endif
end subroutine get_pivoting_qr_${ri}$_workspace
pure module subroutine stdlib_linalg_${ri}$_pivoting_qr(a, q, r, pivots, overwrite_a, storage, err)
!> Input matrix a[m, n]
${rt}$, intent(inout), target :: a(:, :)
!> Orthogonal matrix Q ([m, m] or [m, k] if reduced)
${rt}$, intent(out), contiguous, target :: q(:, :)
!> Upper triangular matrix R ([m, n] or [k, n] if reduced)
${rt}$, intent(out), contiguous, target :: r(:, :)
!> Pivots.
integer(ilp), intent(out) :: pivots(:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Provide pre-allocated workspace, size to be checked with qr_space.
${rt}$, intent(out), optional, target :: storage(:)
!> [optional] state return flag. On error if not requested, the code will stop.
type(linalg_state_type), optional, intent(out) :: err
!> Local variables.
type(linalg_state_type) :: err0
integer(ilp) :: i, j, m, n, k, q1, q2, r1, r2, lda, lwork, info
logical(lk) :: overwrite_a_, use_q_matrix, reduced
${rt}$ :: r11
${rt}$, parameter :: zero = 0.0_${rk}$
${rt}$, pointer :: amat(:, :), tau(:), work(:)
#:if rt.startswith('complex')
real(${rk}$) :: rwork(2*size(a, 2, kind=ilp))
#:endif
!> Problem sizes.
m = size(a, 1, kind=ilp)
n = size(a, 2, kind=ilp)
k = min(m, n)
q1 = size(q, 1, kind=ilp)
q2 = size(q, 2, kind=ilp)
r1 = size(r, 1, kind=ilp)
r2 = size(r, 2, kind=ilp)
pivots = 0_ilp
!> Full or thin QR factorization ?
call check_problem_size(m, n, q1, q2, r1, r2, err0, reduced)
if (err0%error()) then
call linalg_error_handling(err0, err)
return
endif
!> Can Q be used as temporary storage for A,
! to be destroyed by *GEQP3.
use_q_matrix = q1 >= m .and. q2 >= n
!> Can A be overwritten ? (By default, no).
overwrite_a_ = .false._lk
if (present(overwrite_a) .and. .not. use_q_matrix) overwrite_a_ = overwrite_a
!> Initialize a temporary matrix or reuse available storage if possible.
if (use_q_matrix) then
amat(1:q1, 1:q2) => q
q(1:m, 1:n) = a
else if (overwrite_a_) then
amat => a
else
allocate(amat(m, n), source=a)
endif
lda = size(amat, 1, kind=ilp)
!> Store the elementary reflectors.
if (.not. use_q_matrix) then
! Q is not being used as the storage matrix.
tau(1:k) => q(1:k, 1)
else
! R has unused contiguous storage in the 1st column, except for the
! r11 element. Use the full column and store it in a dummy variable.
tau(1:k) => r(1:k, 1)
endif
! Retrieve workspace size.
call get_pivoting_qr_${ri}$_workspace(a, lwork, .true., err0)
if (err0%ok()) then
if (present(storage)) then
work => storage
else
allocate(work(lwork))
endif
if (.not. size(work, kind=ilp) >= lwork) then
err0 = linalg_state_type(this, LINALG_ERROR, "insufficient workspace: should be at least ", lwork)
call linalg_error_handling(err0, err)
return
endif
! Compute factorization.
#:if rt.startswith('complex')
call geqp3(m, n, amat, m, pivots, tau, work, lwork, rwork, info)
#:else
call geqp3(m, n, amat, m, pivots, tau, work, lwork, info)
#:endif
call handle_geqp3_info(this, info, m, n, lwork, err0)
if (err0%ok()) then
! Get R matrix out before overwritten.
! Do not copy the first column at this stage: it may be used by `tau`
r11 = amat(1, 1)
do j = 2, r2
do i = 1, min(r1, m)
r(i, j) = merge(amat(i, j), zero, i <= j)
enddo
enddo
! Convert K elementary reflectors tau(1:k) -> orthogonal matrix Q
call #{if rt.startswith('complex')}#ungqr#{else}#orgqr#{endif}#(q1, q2, k, amat, lda, tau, work, lwork, info)
call handle_orgqr_info(this, info, m, n, k, lwork, err0)
! Copy result back to Q
if (.not.use_q_matrix) q = amat(1:q1, 1:q2)
! Copy first column of R
r(1,1) = r11
r(2:r1,1) = zero
! Ensure last m-n rows of R are zeros,
! if full matrices were provided
if (.not.reduced) r(k+1:m,1:n) = zero
endif
if (.not. present(storage)) deallocate(work)
endif
if (.not.(use_q_matrix.or.overwrite_a_)) deallocate(amat)
! Process output and return
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_${ri}$_pivoting_qr
#:endfor
end submodule stdlib_linalg_qr
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg.fypp 0000664 0001750 0001750 00000273222 15135654166 023742 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set RCI_KINDS_TYPES = RC_KINDS_TYPES + INT_KINDS_TYPES
#:set RHS_SUFFIX = ["one","many"]
#:set RHS_SYMBOL = [ranksuffix(r) for r in [1,2]]
#:set RHS_EMPTY = [emptyranksuffix(r) for r in [1,2]]
#:set ALL_RHS = list(zip(RHS_SYMBOL,RHS_SUFFIX,RHS_EMPTY))
#:set EIG_PROBLEM = ["standard", "generalized"]
#:set EIG_FUNCTION = ["geev","ggev"]
#:set EIG_PROBLEM_LIST = list(zip(EIG_PROBLEM, EIG_FUNCTION))
module stdlib_linalg
!!Provides a support for various linear algebra procedures
!! ([Specification](../page/specs/stdlib_linalg.html))
use stdlib_kinds, only: xdp, int8, int16, int32, int64
use stdlib_linalg_constants, only: sp, dp, qp, lk, ilp
use stdlib_error, only: error_stop
use stdlib_optval, only: optval
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling
implicit none
private
public :: chol
public :: cholesky
public :: det
public :: operator(.det.)
public :: diag
public :: eig
public :: eigh
public :: eigvals
public :: eigvalsh
public :: expm, matrix_exp
public :: eye
public :: inv
public :: invert
public :: operator(.inv.)
public :: pinv
public :: pseudoinvert
public :: operator(.pinv.)
public :: lstsq
public :: lstsq_space
public :: constrained_lstsq
public :: constrained_lstsq_space
public :: norm
public :: mnorm
public :: get_norm
public :: solve
public :: solve_lu
public :: solve_lstsq
public :: solve_constrained_lstsq
public :: trace
public :: svd
public :: svdvals
public :: outer_product
public :: kronecker_product
public :: cross_product
public :: qr
public :: qr_space
public :: schur
public :: schur_space
public :: is_square
public :: is_diagonal
public :: is_symmetric
public :: is_skew_symmetric
public :: hermitian
public :: is_hermitian
public :: is_triangular
public :: is_hessenberg
! Export linalg error handling
public :: linalg_state_type, linalg_error_handling
interface chol
!! version: experimental
!!
!! Computes the Cholesky factorization \( A = L \cdot L^T \), or \( A = U^T \cdot U \).
!! ([Specification](../page/specs/stdlib_linalg.html#chol-compute-the-cholesky-factorization-of-a-rank-2-square-array-matrix))
!!
!!### Summary
!! Pure function interface for computing the Cholesky triangular factors.
!!
!!### Description
!!
!! This interface provides methods for computing the lower- or upper- triangular matrix from the
!! Cholesky factorization of a `real` symmetric or `complex` Hermitian matrix.
!! Supported data types include `real` and `complex`.
!!
!!@note The solution is based on LAPACK's `*POTRF` methods.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
pure module function stdlib_linalg_${ri}$_cholesky_fun(a,lower,other_zeroed) result(c)
!> Input matrix a[m,n]
${rt}$, intent(in) :: a(:,:)
!> [optional] is the lower or upper triangular factor required? Default = lower
logical(lk), optional, intent(in) :: lower
!> [optional] should the unused half of the return matrix be zeroed out? Default: yes
logical(lk), optional, intent(in) :: other_zeroed
!> Output matrix with Cholesky factors c[n,n]
${rt}$ :: c(size(a,1),size(a,2))
end function stdlib_linalg_${ri}$_cholesky_fun
#:endfor
end interface chol
interface cholesky
!! version: experimental
!!
!! Computes the Cholesky factorization \( A = L \cdot L^T \), or \( A = U^T \cdot U \).
!! ([Specification](../page/specs/stdlib_linalg.html#cholesky-compute-the-cholesky-factorization-of-a-rank-2-square-array-matrix))
!!
!!### Summary
!! Pure subroutine interface for computing the Cholesky triangular factors.
!!
!!### Description
!!
!! This interface provides methods for computing the lower- or upper- triangular matrix from the
!! Cholesky factorization of a `real` symmetric or `complex` Hermitian matrix.
!! Supported data types include `real` and `complex`.
!! The factorization is computed in-place if only one matrix argument is present; or returned into
!! a second matrix argument, if present. The `lower` `logical` flag allows to select between upper or
!! lower factorization; the `other_zeroed` optional `logical` flag allows to choose whether the unused
!! part of the triangular matrix should be filled with zeroes.
!!
!!@note The solution is based on LAPACK's `*POTRF` methods.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
pure module subroutine stdlib_linalg_${ri}$_cholesky_inplace(a,lower,other_zeroed,err)
!> Input matrix a[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> [optional] is the lower or upper triangular factor required? Default = lower
logical(lk), optional, intent(in) :: lower
!> [optional] should the unused half of the return matrix be zeroed out? Default: yes
logical(lk), optional, intent(in) :: other_zeroed
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_cholesky_inplace
pure module subroutine stdlib_linalg_${ri}$_cholesky(a,c,lower,other_zeroed,err)
!> Input matrix a[n,n]
${rt}$, intent(in) :: a(:,:)
!> Output matrix with Cholesky factors c[n,n]
${rt}$, intent(out) :: c(:,:)
!> [optional] is the lower or upper triangular factor required? Default = lower
logical(lk), optional, intent(in) :: lower
!> [optional] should the unused half of the return matrix be zeroed out? Default: yes
logical(lk), optional, intent(in) :: other_zeroed
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_cholesky
#:endfor
end interface cholesky
interface diag
!! version: experimental
!!
!! Creates a diagonal array or extract the diagonal elements of an array
!! ([Specification](../page/specs/stdlib_linalg.html#
!! diag-create-a-diagonal-array-or-extract-the-diagonal-elements-of-an-array))
!
! Vector to matrix
!
#:for k1, t1 in RCI_KINDS_TYPES
pure module function diag_${t1[0]}$${k1}$(v) result(res)
${t1}$, intent(in) :: v(:)
${t1}$ :: res(size(v),size(v))
end function diag_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
pure module function diag_${t1[0]}$${k1}$_k(v,k) result(res)
${t1}$, intent(in) :: v(:)
integer, intent(in) :: k
${t1}$ :: res(size(v)+abs(k),size(v)+abs(k))
end function diag_${t1[0]}$${k1}$_k
#:endfor
!
! Matrix to vector
!
#:for k1, t1 in RCI_KINDS_TYPES
pure module function diag_${t1[0]}$${k1}$_mat(A) result(res)
${t1}$, intent(in) :: A(:,:)
${t1}$ :: res(minval(shape(A)))
end function diag_${t1[0]}$${k1}$_mat
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
pure module function diag_${t1[0]}$${k1}$_mat_k(A,k) result(res)
${t1}$, intent(in) :: A(:,:)
integer, intent(in) :: k
${t1}$ :: res(minval(shape(A))-abs(k))
end function diag_${t1[0]}$${k1}$_mat_k
#:endfor
end interface
! Matrix trace
interface trace
!! version: experimental
!!
!! Computes the trace of a matrix
!! ([Specification](../page/specs/stdlib_linalg.html#
!! trace-trace-of-a-matrix))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure trace_${t1[0]}$${k1}$
#:endfor
end interface
! Identity matrix
interface eye
!! version: experimental
!!
!! Constructs the identity matrix
!! ([Specification](../page/specs/stdlib_linalg.html#eye-construct-the-identity-matrix))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure eye_${t1[0]}$${k1}$
#:endfor
end interface eye
! Outer product (of two vectors)
interface outer_product
!! version: experimental
!!
!! Computes the outer product of two vectors, returning a rank-2 array
!! ([Specification](../page/specs/stdlib_linalg.html#
!! outer_product-computes-the-outer-product-of-two-vectors))
#:for k1, t1 in RCI_KINDS_TYPES
pure module function outer_product_${t1[0]}$${k1}$(u, v) result(res)
${t1}$, intent(in) :: u(:), v(:)
${t1}$ :: res(size(u),size(v))
end function outer_product_${t1[0]}$${k1}$
#:endfor
end interface outer_product
interface kronecker_product
!! version: experimental
!!
!! Computes the Kronecker product of two arrays of size M1xN1, and of M2xN2, returning an (M1*M2)x(N1*N2) array
!! ([Specification](../page/specs/stdlib_linalg.html#
!! kronecker_product-computes-the-kronecker-product-of-two-matrices))
#:for k1, t1 in RCI_KINDS_TYPES
pure module function kronecker_product_${t1[0]}$${k1}$(A, B) result(C)
${t1}$, intent(in) :: A(:,:), B(:,:)
${t1}$ :: C(size(A,dim=1)*size(B,dim=1),size(A,dim=2)*size(B,dim=2))
end function kronecker_product_${t1[0]}$${k1}$
#:endfor
end interface kronecker_product
! Cross product (of two vectors)
interface cross_product
!! version: experimental
!!
!! Computes the cross product of two vectors, returning a rank-1 and size-3 array
!! ([Specification](../page/specs/stdlib_linalg.html#cross_product-computes-the-cross-product-of-two-3-d-vectors))
#:for k1, t1 in RCI_KINDS_TYPES
pure module function cross_product_${t1[0]}$${k1}$(a, b) result(res)
${t1}$, intent(in) :: a(3), b(3)
${t1}$ :: res(3)
end function cross_product_${t1[0]}$${k1}$
#:endfor
end interface cross_product
! Check for squareness
interface is_square
!! version: experimental
!!
!! Checks if a matrix (rank-2 array) is square
!! ([Specification](../page/specs/stdlib_linalg.html#
!! is_square-checks-if-a-matrix-is-square))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure is_square_${t1[0]}$${k1}$
#:endfor
end interface is_square
! Check for diagonality
interface is_diagonal
!! version: experimental
!!
!! Checks if a matrix (rank-2 array) is diagonal
!! ([Specification](../page/specs/stdlib_linalg.html#
!! is_diagonal-checks-if-a-matrix-is-diagonal))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure is_diagonal_${t1[0]}$${k1}$
#:endfor
end interface is_diagonal
! Check for symmetry
interface is_symmetric
!! version: experimental
!!
!! Checks if a matrix (rank-2 array) is symmetric
!! ([Specification](../page/specs/stdlib_linalg.html#
!! is_symmetric-checks-if-a-matrix-is-symmetric))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure is_symmetric_${t1[0]}$${k1}$
#:endfor
end interface is_symmetric
! Check for skew-symmetry
interface is_skew_symmetric
!! version: experimental
!!
!! Checks if a matrix (rank-2 array) is skew-symmetric
!! ([Specification](../page/specs/stdlib_linalg.html#
!! is_skew_symmetric-checks-if-a-matrix-is-skew-symmetric))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure is_skew_symmetric_${t1[0]}$${k1}$
#:endfor
end interface is_skew_symmetric
! Check for Hermiticity
interface is_hermitian
!! version: experimental
!!
!! Checks if a matrix (rank-2 array) is Hermitian
!! ([Specification](../page/specs/stdlib_linalg.html#
!! is_hermitian-checks-if-a-matrix-is-hermitian))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure is_hermitian_${t1[0]}$${k1}$
#:endfor
end interface is_hermitian
interface hermitian
!! version: experimental
!!
!! Computes the Hermitian version of a rank-2 matrix.
!! For complex matrices, this returns `conjg(transpose(a))`.
!! For real or integer matrices, this returns `transpose(a)`.
!!
!! Usage:
!! ```
!! A = reshape([(1, 2), (3, 4), (5, 6), (7, 8)], [2, 2])
!! AH = hermitian(A)
!! ```
!!
!! [Specification](../page/specs/stdlib_linalg.html#hermitian-compute-the-hermitian-version-of-a-rank-2-matrix)
!!
#:for k1, t1 in RCI_KINDS_TYPES
pure module function hermitian_${t1[0]}$${k1}$(a) result(ah)
${t1}$, intent(in) :: a(:,:)
${t1}$ :: ah(size(a, 2), size(a, 1))
end function hermitian_${t1[0]}$${k1}$
#:endfor
end interface hermitian
! Check for triangularity
interface is_triangular
!! version: experimental
!!
!! Checks if a matrix (rank-2 array) is triangular
!! ([Specification](../page/specs/stdlib_linalg.html#
!! is_triangular-checks-if-a-matrix-is-triangular))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure is_triangular_${t1[0]}$${k1}$
#:endfor
end interface is_triangular
! Check for matrix being Hessenberg
interface is_hessenberg
!! version: experimental
!!
!! Checks if a matrix (rank-2 array) is Hessenberg
!! ([Specification](../page/specs/stdlib_linalg.html#
!! is_hessenberg-checks-if-a-matrix-is-hessenberg))
#:for k1, t1 in RCI_KINDS_TYPES
module procedure is_Hessenberg_${t1[0]}$${k1}$
#:endfor
end interface is_hessenberg
! Solve linear system system Ax=b.
interface solve
!! version: experimental
!!
!! Solves the linear system \( A \cdot x = b \) for the unknown vector \( x \) from a square matrix \( A \).
!! ([Specification](../page/specs/stdlib_linalg.html#solve-solves-a-linear-matrix-equation-or-a-linear-system-of-equations))
!!
!!### Summary
!! Interface for solving a linear system arising from a general matrix.
!!
!!### Description
!!
!! This interface provides methods for computing the solution of a linear matrix system.
!! Supported data types include `real` and `complex`. No assumption is made on the matrix
!! structure.
!! The function can solve simultaneously either one (from a 1-d right-hand-side vector `b(:)`)
!! or several (from a 2-d right-hand-side vector `b(:,:)`) systems.
!!
!!@note The solution is based on LAPACK's generic LU decomposition based solvers `*GESV`.
!!
#:for nd,ndsuf,nde in ALL_RHS
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_${ri}$_solve_${ndsuf}$(a,b,overwrite_a,err) result(x)
!> Input matrix a[n,n]
${rt}$, intent(inout), target :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out) :: err
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, allocatable, target :: x${nd}$
end function stdlib_linalg_${ri}$_solve_${ndsuf}$
pure module function stdlib_linalg_${ri}$_pure_solve_${ndsuf}$(a,b) result(x)
!> Input matrix a[n,n]
${rt}$, intent(in) :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, allocatable, target :: x${nd}$
end function stdlib_linalg_${ri}$_pure_solve_${ndsuf}$
#:endfor
#:endfor
end interface solve
! Solve linear system Ax = b using LU decomposition (subroutine interface).
interface solve_lu
!! version: experimental
!!
!! Solves the linear system \( A \cdot x = b \) for the unknown vector \( x \) from a square matrix \( A \).
!! ([Specification](../page/specs/stdlib_linalg.html#solve-lu-solves-a-linear-matrix-equation-or-a-linear-system-of-equations-subroutine-interface))
!!
!!### Summary
!! Subroutine interface for solving a linear system using LU decomposition.
!!
!!### Description
!!
!! This interface provides methods for computing the solution of a linear matrix system using
!! a subroutine. Supported data types include `real` and `complex`. No assumption is made on the matrix
!! structure. Preallocated space for the solution vector `x` is user-provided, and it may be provided
!! for the array of pivot indices, `pivot`. If all pre-allocated work spaces are provided, no internal
!! memory allocations take place when using this interface.
!! The function can solve simultaneously either one (from a 1-d right-hand-side vector `b(:)`)
!! or several (from a 2-d right-hand-side vector `b(:,:)`) systems.
!!
!!@note The solution is based on LAPACK's generic LU decomposition based solvers `*GESV`.
!!
#:for nd,ndsuf,nde in ALL_RHS
#:for rk,rt,ri in RC_KINDS_TYPES
pure module subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$(a,b,x,pivot,overwrite_a,err)
!> Input matrix a[n,n]
${rt}$, intent(inout), target :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, intent(inout), contiguous, target :: x${nd}$
!> [optional] Storage array for the diagonal pivot indices
integer(ilp), optional, intent(inout), target :: pivot(:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$
#:endfor
#:endfor
end interface solve_lu
! Least squares solution to system Ax=b, i.e. such that the 2-norm abs(b-Ax) is minimized.
interface lstsq
!! version: experimental
!!
!! Computes the squares solution to system \( A \cdot x = b \).
!! ([Specification](../page/specs/stdlib_linalg.html#lstsq-computes-the-least-squares-solution-to-a-linear-matrix-equation))
!!
!!### Summary
!! Interface for computing least squares, i.e. the 2-norm \( || (b-A \cdot x ||_2 \) minimizing solution.
!!
!!### Description
!!
!! This interface provides methods for computing the least squares of a linear matrix system.
!! Supported data types include `real` and `complex`.
!!
!!@note The solution is based on LAPACK's singular value decomposition `*GELSD` methods.
!!
#:for nd,ndsuf,nde in ALL_RHS
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_${ri}$_lstsq_${ndsuf}$(a,b,cond,overwrite_a,rank,err) result(x)
!> Input matrix a[n,n]
${rt}$, intent(inout), target :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> [optional] cutoff for rank evaluation: singular values s(i)<=cond*maxval(s) are considered 0.
real(${rk}$), optional, intent(in) :: cond
!> [optional] Can A,b data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Return rank of A
integer(ilp), optional, intent(out) :: rank
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, allocatable, target :: x${nd}$
end function stdlib_linalg_${ri}$_lstsq_${ndsuf}$
#:endfor
#:endfor
end interface lstsq
! Least squares solution to system Ax=b, i.e. such that the 2-norm abs(b-Ax) is minimized.
interface solve_lstsq
!! version: experimental
!!
!! Computes the squares solution to system \( A \cdot x = b \).
!! ([Specification](../page/specs/stdlib_linalg.html#solve-lstsq-compute-the-least-squares-solution-to-a-linear-matrix-equation-subroutine-interface))
!!
!!### Summary
!! Subroutine interface for computing least squares, i.e. the 2-norm \( || (b-A \cdot x ||_2 \) minimizing solution.
!!
!!### Description
!!
!! This interface provides methods for computing the least squares of a linear matrix system using
!! a subroutine. Supported data types include `real` and `complex`. If pre-allocated work spaces
!! are provided, no internal memory allocations take place when using this interface.
!!
!!@note The solution is based on LAPACK's singular value decomposition `*GELSD` methods.
!!
#:for nd,ndsuf,nde in ALL_RHS
#:for rk,rt,ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$(a,b,x,real_storage,int_storage,&
#{if rt.startswith('c')}#cmpl_storage,#{endif}#cond,singvals,overwrite_a,rank,err)
!> Input matrix a[n,n]
${rt}$, intent(inout), target :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, intent(inout), contiguous, target :: x${nd}$
!> [optional] real working storage space
real(${rk}$), optional, intent(inout), target :: real_storage(:)
!> [optional] integer working storage space
integer(ilp), optional, intent(inout), target :: int_storage(:)
#:if rt.startswith('complex')
!> [optional] complex working storage space
${rt}$, optional, intent(inout), target :: cmpl_storage(:)
#:endif
!> [optional] cutoff for rank evaluation: singular values s(i)<=cond*maxval(s) are considered 0.
real(${rk}$), optional, intent(in) :: cond
!> [optional] list of singular values [min(m,n)], in descending magnitude order, returned by the SVD
real(${rk}$), optional, intent(out), target :: singvals(:)
!> [optional] Can A,b data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Return rank of A
integer(ilp), optional, intent(out) :: rank
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$
#:endfor
#:endfor
end interface solve_lstsq
! Return the working array space required by the least squares solver
interface lstsq_space
!! version: experimental
!!
!! Computes the integer, real [, complex] working space required by the least-squares solver
!! ([Specification](../page/specs/stdlib_linalg.html#lstsq-space-compute-internal-working-space-requirements-for-the-least-squares-solver))
!!
!!### Description
!!
!! This interface provides sizes of integer, real [, complex] working spaces required by the
!! least-squares solver. These sizes can be used to pre-allocated working arrays in case several
!! repeated least-squares solutions to a same system are sought. If pre-allocated working arrays
!! are provided, no internal allocations will take place.
!!
#:for nd,ndsuf,nde in ALL_RHS
#:for rk,rt,ri in RC_KINDS_TYPES
pure module subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$(a,b,lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> Size of the working space arrays
integer(ilp), intent(out) :: lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#
end subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$
#:endfor
#:endfor
end interface lstsq_space
! Equality-constrained least-squares, i.e. minimize the sum of squares
! cost || Ax - b ||^2 subject to the equality constraint Cx = d.
interface constrained_lstsq
!! version: experimental
!!
!! Computes the solution of the equality constrained least-squares problem
!!
!! minimize || Ax - b ||²
!! subject to Cx = d
!!
!! where A is of size `m x n` and C of size `p x n`.
!! ([Specification](../page/specs/stdlib_linalg.html#constrained-lstsq))
!!
!! ### Description
!!
!! This interface provides methods for computing the solution of an equality-constrained
!! least-squares problem using a function. Supported data types include `real` and
!! `complex`.
!!
!! @note The solution is based on LAPACK's `*GGLSE` methods.
#:for rk, rt, ri in RC_KINDS_TYPES
module function stdlib_linalg_${ri}$_constrained_lstsq(A, b, C, d, overwrite_matrices, err) result(x)
!> Least-squares cost
${rt}$, intent(inout), target :: A(:, :), b(:)
!> Equality constraints.
${rt}$, intent(inout), target :: C(:, :), d(:)
!> [optional] Can A and C be overwritten?
logical(lk), optional, intent(in) :: overwrite_matrices
!> [optional] State return flag.
type(linalg_state_type), optional, intent(out) :: err
!> Solution of the constrained least-squares problem.
${rt}$, allocatable, target :: x(:)
end function stdlib_linalg_${ri}$_constrained_lstsq
#:endfor
end interface
! Equality-constrained least-squares, i.e. minimize the sum of squares
! cost || Ax - b ||^2 subject to the equality constraint Cx = d.
interface solve_constrained_lstsq
!! version: experimental
!!
!! Computes the solution of the equality constrained least-squares problem
!!
!! minimize || Ax - b ||²
!! subject to Cx = d
!!
!! where A is of size `m x n` and C of size `p x n`.
!! ([Specification](../page/specs/stdlib_linalg.html#solve-constrained-lstsq))
!!
!! ### Description
!!
!! This interface provides methods for computing the solution of an equality-constrained
!! least-squares problem using a subroutine. Supported data types include `real` and
!! `complex`. If a pre-allocated workspace is provided, no internal memory allocation takes
!! place.
!!
!! @note The solution is based on LAPACK's `*GGLSE` methods.
#:for rk, rt, ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_${ri}$_solve_constrained_lstsq(A, b, C, d, x, storage, overwrite_matrices, err)
!> Least-squares cost.
${rt}$, intent(inout), target :: A(:, :), b(:)
!> Equality constraints.
${rt}$, intent(inout), target :: C(:, :), d(:)
!> Solution vector.
${rt}$, intent(out) :: x(:)
!> [optional] Storage.
${rt}$, optional, intent(out), target :: storage(:)
!> [optional] Can A and C be overwritten?
logical(lk), optional, intent(in) :: overwrite_matrices
!> [optional] State return flag. On error if not requested, the code stops.
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_solve_constrained_lstsq
#:endfor
end interface
interface constrained_lstsq_space
!! version: experimental
!!
!! Computes the size of the workspace required by the constrained least-squares solver.
!! ([Specification](../page/specs/stdlib_linalg.html#constrained-lstsq-space))
!!
!! ### Description
!!
!! This interface provides the size of the workspace array required by the constrained
!! least-squares solver. It can be used to pre-allocate the working array in
!! case several repeated solutions to a same system are sought. If pre-allocated,
!! working arrays are provided, no internal allocation will take place.
!!
#:for rk, rt, ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_${ri}$_constrained_lstsq_space(A, C, lwork, err)
!> Least-squares cost.
${rt}$, intent(in) :: A(:, :)
!> Equality constraints.
${rt}$, intent(in) :: C(:, :)
integer(ilp), intent(out) :: lwork
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_constrained_lstsq_space
#:endfor
end interface
! QR factorization of rank-2 array A
interface qr
!! version: experimental
!!
!! Computes the QR factorization of matrix \( A = Q R \).
!! ([Specification](../page/specs/stdlib_linalg.html#qr-compute-the-qr-factorization-of-a-matrix))
!!
!!### Summary
!! Compute the QR factorization of a `real` or `complex` matrix: \( A = Q R \), where \( Q \) is orthonormal
!! and \( R \) is upper-triangular. Matrix \( A \) has size `[m,n]`, with \( m\ge n \).
!!
!!### Description
!!
!! This interface provides methods for computing the QR factorization of a matrix.
!! Supported data types include `real` and `complex`. If a pre-allocated work space
!! is provided, no internal memory allocations take place when using this interface.
!!
!! Given `k = min(m,n)`, one can write \( A = \( Q_1 Q_2 \) \cdot \( \frac{R_1}{0}\) \).
!! The user may want the full problem (provide `shape(Q)==[m,m]`, `shape(R)==[m,n]`) or the reduced
!! problem only: \( A = Q_1 R_1 \) (provide `shape(Q)==[m,k]`, `shape(R)==[k,n]`).
!!
!!@note The solution is based on LAPACK's QR factorization (`*GEQRF`) and ordered matrix output (`*ORGQR`, `*UNGQR`).
!!
#:for rk,rt,ri in RC_KINDS_TYPES
pure module subroutine stdlib_linalg_${ri}$_qr(a,q,r,overwrite_a,storage,err)
!> Input matrix a[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> Orthogonal matrix Q ([m,m], or [m,k] if reduced)
${rt}$, intent(out), contiguous, target :: q(:,:)
!> Upper triangular matrix R ([m,n], or [k,n] if reduced)
${rt}$, intent(out), contiguous, target :: r(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Provide pre-allocated workspace, size to be checked with qr_space
${rt}$, intent(out), optional, target :: storage(:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_qr
pure module subroutine stdlib_linalg_${ri}$_pivoting_qr(a, q, r, pivots, overwrite_a, storage, err)
!> Input matrix a[m, n]
${rt}$, intent(inout), target :: a(:, :)
!> Orthogonal matrix Q ([m, m] or [m, k] if reduced)
${rt}$, intent(out), contiguous, target :: q(:, :)
!> Upper triangular matrix R ([m, n] or [k, n] if reduced)
${rt}$, intent(out), contiguous, target :: r(:, :)
!> Pivots.
integer(ilp), intent(out) :: pivots(:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Provide pre-allocated workspace, size to be checked with qr_space.
${rt}$, intent(out), optional, target :: storage(:)
!> [optional] state return flag. On error if not requested, the code will stop.
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_pivoting_qr
#:endfor
end interface qr
! Return the working array space required by the QR factorization solver
interface qr_space
!! version: experimental
!!
!! Computes the working array space required by the QR factorization solver
!! ([Specification](../page/specs/stdlib_linalg.html#qr-space-compute-internal-working-space-requirements-for-the-qr-factorization))
!!
!!### Description
!!
!! This interface returns the size of the `real` or `complex` working storage required by the
!! QR factorization solver. The working size only depends on the kind (`real` or `complex`) and size of
!! the matrix being factorized. Storage size can be used to pre-allocate a working array in case several
!! repeated QR factorizations to a same-size matrix are sought. If pre-allocated working arrays
!! are provided, no internal allocations will take place during the factorization.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
pure module subroutine get_qr_${ri}$_workspace(a,lwork,err)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> Minimum workspace size for both operations
integer(ilp), intent(out) :: lwork
!> State return flag. Returns an error if the query failed
type(linalg_state_type), optional, intent(out) :: err
end subroutine get_qr_${ri}$_workspace
pure module subroutine get_pivoting_qr_${ri}$_workspace(a, lwork, pivoting, err)
!> Input matrix a[m, n]
${rt}$, intent(in), target :: a(:, :)
!> Minimum workspace size for both operations.
integer(ilp), intent(out) :: lwork
!> Pivoting flag.
logical(lk), intent(in) :: pivoting
!> State return flag. Returns an error if the query failed.
type(linalg_state_type), optional, intent(out) :: err
end subroutine get_pivoting_qr_${ri}$_workspace
#:endfor
end interface qr_space
! Schur decomposition of rank-2 array A
interface schur
!! version: experimental
!!
!! Computes the Schur decomposition of matrix \( A = Z T Z^H \).
!! ([Specification](../page/specs/stdlib_linalg.html#schur-compute-the-schur-decomposition-of-a-matrix))
!!
!!### Summary
!! Compute the Schur decomposition of a `real` or `complex` matrix: \( A = Z T Z^H \), where \( Z \) is
!! orthonormal/unitary and \( T \) is upper-triangular or quasi-upper-triangular. Matrix \( A \) has size `[m,m]`.
!!
!!### Description
!!
!! This interface provides methods for computing the Schur decomposition of a matrix.
!! Supported data types include `real` and `complex`. If a pre-allocated workspace is provided, no internal
!! memory allocations take place when using this interface.
!!
!! The output matrix \( T \) is upper-triangular for `complex` input matrices and quasi-upper-triangular
!! for `real` input matrices (with possible \( 2 \times 2 \) blocks on the diagonal).
!!
!!@note The solution is based on LAPACK's Schur decomposition routines (`*GEES`).
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_${ri}$_schur(a, t, z, eigvals, overwrite_a, storage, err)
!> Input matrix a[m,m]
${rt}$, intent(inout), target :: a(:,:)
!> Schur form of A: upper-triangular or quasi-upper-triangular matrix T
${rt}$, intent(out), contiguous, target :: t(:,:)
!> Unitary/orthonormal transformation matrix Z
${rt}$, optional, intent(out), contiguous, target :: z(:,:)
!> [optional] Output eigenvalues that appear on the diagonal of T
complex(${rk}$), optional, intent(out), contiguous, target :: eigvals(:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Provide pre-allocated workspace, size to be checked with schur_space
${rt}$, optional, intent(inout), target :: storage(:)
!> [optional] State return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_schur
! Schur decomposition subroutine: real eigenvalue interface
module subroutine stdlib_linalg_real_eig_${ri}$_schur(a,t,z,eigvals,overwrite_a,storage,err)
!> Input matrix a[m,m]
${rt}$, intent(inout), target :: a(:,:)
!> Schur form of A: upper-triangular or quasi-upper-triangular matrix T
${rt}$, intent(out), contiguous, target :: t(:,:)
!> Unitary/orthonormal transformation matrix Z
${rt}$, optional, intent(out), contiguous, target :: z(:,:)
!> Output real eigenvalues that appear on the diagonal of T
real(${rk}$), intent(out), contiguous, target :: eigvals(:)
!> [optional] Provide pre-allocated workspace, size to be checked with schur_space
${rt}$, optional, intent(inout), target :: storage(:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] State return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_real_eig_${ri}$_schur
#:endfor
end interface schur
! Return the working array space required by the Schur decomposition solver
interface schur_space
!! version: experimental
!!
!! Computes the working array space required by the Schur decomposition solver
!! ([Specification](../page/specs/stdlib_linalg.html#schur-space-compute-internal-working-space-requirements-for-the-schur-decomposition))
!!
!!### Description
!!
!! This interface returns the size of the `real` or `complex` working storage required by the
!! Schur decomposition solver. The working size only depends on the kind (`real` or `complex`) and size of
!! the matrix being decomposed. Storage size can be used to pre-allocate a working array in case several
!! repeated Schur decompositions of same-size matrices are sought. If pre-allocated working arrays
!! are provided, no internal allocations will take place during the decomposition.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module subroutine get_schur_${ri}$_workspace(a,lwork,err)
!> Input matrix a[m,m]
${rt}$, intent(in), target :: a(:,:)
!> Minimum workspace size for the decomposition operation
integer(ilp), intent(out) :: lwork
!> State return flag. Returns an error if the query failed
type(linalg_state_type), optional, intent(out) :: err
end subroutine get_schur_${ri}$_workspace
#:endfor
end interface schur_space
interface det
!! version: experimental
!!
!! Computes the determinant of a square matrix
!! ([Specification](../page/specs/stdlib_linalg.html#det-computes-the-determinant-of-a-square-matrix))
!!
!!### Summary
!! Interface for computing matrix determinant.
!!
!!### Description
!!
!! This interface provides methods for computing the determinant of a matrix.
!! Supported data types include `real` and `complex`.
!!
!!@note The provided functions are intended for square matrices only.
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
!!
!!### Example
!!
!!```fortran
!!
!! real(sp) :: a(3,3), d
!! type(linalg_state_type) :: state
!! a = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!!
!! ! ...
!! d = det(a,err=state)
!! if (state%ok()) then
!! print *, 'Success! det=',d
!! else
!! print *, state%print()
!! endif
!! ! ...
!!```
!!
#:for rk,rt in RC_KINDS_TYPES
#:if rk!="xdp"
module procedure stdlib_linalg_${rt[0]}$${rk}$determinant
module procedure stdlib_linalg_pure_${rt[0]}$${rk}$determinant
#:endif
#:endfor
end interface det
interface operator(.det.)
!! version: experimental
!!
!! Determinant operator of a square matrix
!! ([Specification](../page/specs/stdlib_linalg.html#det-determinant-operator-of-a-square-matrix))
!!
!!### Summary
!! Pure operator interface for computing matrix determinant.
!!
!!### Description
!!
!! This pure operator interface provides a convenient way to compute the determinant of a matrix.
!! Supported data types include real and complex.
!!
!!@note The provided functions are intended for square matrices.
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
!!
!!### Example
!!
!!```fortran
!!
!! ! ...
!! real(sp) :: matrix(3,3), d
!! matrix = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!! d = .det.matrix
!! ! ...
!!
!!```
!
#:for rk,rt in RC_KINDS_TYPES
#:if rk!="xdp"
module procedure stdlib_linalg_pure_${rt[0]}$${rk}$determinant
#:endif
#:endfor
end interface operator(.det.)
interface
#:for rk,rt in RC_KINDS_TYPES
#:if rk!="xdp"
module function stdlib_linalg_${rt[0]}$${rk}$determinant(a,overwrite_a,err) result(det)
!> Input matrix a[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> State return flag.
type(linalg_state_type), intent(out) :: err
!> Matrix determinant
${rt}$ :: det
end function stdlib_linalg_${rt[0]}$${rk}$determinant
pure module function stdlib_linalg_pure_${rt[0]}$${rk}$determinant(a) result(det)
!> Input matrix a[m,n]
${rt}$, intent(in) :: a(:,:)
!> Matrix determinant
${rt}$ :: det
end function stdlib_linalg_pure_${rt[0]}$${rk}$determinant
#:endif
#:endfor
end interface
! Matrix Inverse: Function interface
interface inv
!! version: experimental
!!
!! Inverse of a square matrix
!! ([Specification](../page/specs/stdlib_linalg.html#inv-inverse-of-a-square-matrix))
!!
!!### Summary
!! This interface provides methods for computing the inverse of a square `real` or `complex` matrix.
!! The inverse \( A^{-1} \) is defined such that \( A \cdot A^{-1} = A^{-1} \cdot A = I_n \).
!!
!!### Description
!!
!! This function interface provides methods that return the inverse of a square matrix.
!! Supported data types include `real` and `complex`.
!! The inverse matrix \( A^{-1} \) is returned as a function result.
!! Exceptions are raised in case of singular matrix or invalid size, and trigger an `error stop` if
!! the state flag `err` is not provided.
!!
!!@note The provided functions are intended for square matrices.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_inverse_${ri}$(a,err) result(inva)
!> Input matrix a[n,n]
${rt}$, intent(in) :: a(:,:)
!> Output matrix inverse
${rt}$, allocatable :: inva(:,:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end function stdlib_linalg_inverse_${ri}$
#:endfor
end interface inv
! Matrix Inverse: Subroutine interface - in-place inversion
interface invert
!! version: experimental
!!
!! Inversion of a square matrix
!! ([Specification](../page/specs/stdlib_linalg.html#invert-inversion-of-a-square-matrix))
!!
!!### Summary
!! This interface provides methods for inverting a square `real` or `complex` matrix in-place.
!! The inverse \( A^{-1} \) is defined such that \( A \cdot A^{-1} = A^{-1} \cdot A = I_n \).
!!
!!### Description
!!
!! This subroutine interface provides a way to compute the inverse of a matrix.
!! Supported data types include `real` and `complex`.
!! The user may provide a unique matrix argument `a`. In this case, `a` is replaced by the inverse matrix.
!! on output. Otherwise, one may provide two separate arguments: an input matrix `a` and an output matrix
!! `inva`. In this case, `a` will not be modified, and the inverse is returned in `inva`.
!! Pre-allocated storage may be provided for the array of pivot indices, `pivot`. If all pre-allocated
!! work spaces are provided, no internal memory allocations take place when using this interface.
!!
!!@note The provided subroutines are intended for square matrices.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_invert_inplace_${ri}$(a,pivot,err)
!> Input matrix a[n,n]
${rt}$, intent(inout) :: a(:,:)
!> [optional] Storage array for the diagonal pivot indices
integer(ilp), optional, intent(inout), target :: pivot(:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_invert_inplace_${ri}$
! Compute the square matrix inverse of a
module subroutine stdlib_linalg_invert_split_${ri}$(a,inva,pivot,err)
!> Input matrix a[n,n].
${rt}$, intent(in) :: a(:,:)
!> Inverse matrix a[n,n].
${rt}$, intent(out) :: inva(:,:)
!> [optional] Storage array for the diagonal pivot indices
integer(ilp), optional, intent(inout), target :: pivot(:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_invert_split_${ri}$
#:endfor
end interface invert
! Matrix Inverse: Operator interface
interface operator(.inv.)
!! version: experimental
!!
!! Inverse operator of a square matrix
!! ([Specification](../page/specs/stdlib_linalg.html#inv-inverse-operator-of-a-square-matrix))
!!
!!### Summary
!! Operator interface for computing the inverse of a square `real` or `complex` matrix.
!!
!!### Description
!!
!! This operator interface provides a convenient way to compute the inverse of a matrix.
!! Supported data types include `real` and `complex`. On input errors or singular matrix,
!! NaNs will be returned.
!!
!!@note The provided functions are intended for square matrices.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_inverse_${ri}$_operator(a) result(inva)
!> Input matrix a[n,n]
${rt}$, intent(in) :: a(:,:)
!> Result matrix
${rt}$, allocatable :: inva(:,:)
end function stdlib_linalg_inverse_${ri}$_operator
#:endfor
end interface operator(.inv.)
! Moore-Penrose Pseudo-Inverse: Function interface
interface pinv
!! version: experimental
!!
!! Pseudo-inverse of a matrix
!! ([Specification](../page/specs/stdlib_linalg.html#pinv-moore-penrose-pseudo-inverse-of-a-matrix))
!!
!!### Summary
!! This interface provides methods for computing the Moore-Penrose pseudo-inverse of a matrix.
!! The pseudo-inverse \( A^{+} \) is a generalization of the matrix inverse, computed for square, singular,
!! or rectangular matrices. It is defined such that it satisfies the conditions:
!! - \( A \cdot A^{+} \cdot A = A \)
!! - \( A^{+} \cdot A \cdot A^{+} = A^{+} \)
!! - \( (A \cdot A^{+})^T = A \cdot A^{+} \)
!! - \( (A^{+} \cdot A)^T = A^{+} \cdot A \)
!!
!!### Description
!!
!! This function interface provides methods that return the Moore-Penrose pseudo-inverse of a matrix.
!! Supported data types include `real` and `complex`.
!! The pseudo-inverse \( A^{+} \) is returned as a function result. The computation is based on the
!! singular value decomposition (SVD). An optional relative tolerance `rtol` is provided to control the
!! inclusion of singular values during inversion. Singular values below \( \text{rtol} \cdot \sigma_{\max} \)
!! are treated as zero, where \( \sigma_{\max} \) is the largest singular value. If `rtol` is not provided,
!! a default threshold is applied.
!!
!! Exceptions are raised in case of computational errors or invalid input, and trigger an `error stop`
!! if the state flag `err` is not provided.
!!
!!@note The provided functions are intended for both rectangular and square matrices.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_pseudoinverse_${ri}$(a,rtol,err) result(pinva)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> [optional] Relative tolerance for singular value cutoff
real(${rk}$), optional, intent(in) :: rtol
!> [optional] State return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Output matrix pseudo-inverse [n,m]
${rt}$ :: pinva(size(a,2,kind=ilp),size(a,1,kind=ilp))
end function stdlib_linalg_pseudoinverse_${ri}$
#:endfor
end interface pinv
! Moore-Penrose Pseudo-Inverse: Subroutine interface
interface pseudoinvert
!! version: experimental
!!
!! Computation of the Moore-Penrose pseudo-inverse
!! ([Specification](../page/specs/stdlib_linalg.html#pseudoinvert-moore-penrose-pseudo-inverse-of-a-matrix))
!!
!!### Summary
!! This interface provides methods for computing the Moore-Penrose pseudo-inverse of a rectangular
!! or square `real` or `complex` matrix.
!! The pseudo-inverse \( A^{+} \) generalizes the matrix inverse and satisfies the properties:
!! - \( A \cdot A^{+} \cdot A = A \)
!! - \( A^{+} \cdot A \cdot A^{+} = A^{+} \)
!! - \( (A \cdot A^{+})^T = A \cdot A^{+} \)
!! - \( (A^{+} \cdot A)^T = A^{+} \cdot A \)
!!
!!### Description
!!
!! This subroutine interface provides a way to compute the Moore-Penrose pseudo-inverse of a matrix.
!! Supported data types include `real` and `complex`.
!! Users must provide two matrices: the input matrix `a` [m,n] and the output pseudo-inverse `pinva` [n,m].
!! The input matrix `a` is used to compute the pseudo-inverse and is not modified. The computed
!! pseudo-inverse is stored in `pinva`. The computation is based on the singular value decomposition (SVD).
!!
!! An optional relative tolerance `rtol` is used to control the inclusion of singular values in the
!! computation. Singular values below \( \text{rtol} \cdot \sigma_{\max} \) are treated as zero,
!! where \( \sigma_{\max} \) is the largest singular value. If `rtol` is not provided, a default
!! threshold is applied.
!!
!! Exceptions are raised in case of computational errors or invalid input, and trigger an `error stop`
!! if the state flag `err` is not provided.
!!
!!@note The provided subroutines are intended for both rectangular and square matrices.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_pseudoinvert_${ri}$(a,pinva,rtol,err)
!> Input matrix a[m,n]
${rt}$, intent(inout) :: a(:,:)
!> Output pseudo-inverse matrix [n,m]
${rt}$, intent(out) :: pinva(:,:)
!> [optional] Relative tolerance for singular value cutoff
real(${rk}$), optional, intent(in) :: rtol
!> [optional] State return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_pseudoinvert_${ri}$
#:endfor
end interface pseudoinvert
! Moore-Penrose Pseudo-Inverse: Operator interface
interface operator(.pinv.)
!! version: experimental
!!
!! Pseudo-inverse operator of a matrix
!! ([Specification](../page/specs/stdlib_linalg.html#pinv-moore-penrose-pseudo-inverse-operator))
!!
!!### Summary
!! Operator interface for computing the Moore-Penrose pseudo-inverse of a `real` or `complex` matrix.
!!
!!### Description
!!
!! This operator interface provides a convenient way to compute the Moore-Penrose pseudo-inverse
!! of a matrix. Supported data types include `real` and `complex`. The pseudo-inverse \( A^{+} \)
!! is computed using singular value decomposition (SVD), with singular values below an internal
!! threshold treated as zero.
!!
!! For computational errors or invalid input, the function may return a matrix filled with NaNs.
!!
!!@note The provided functions are intended for both rectangular and square matrices.
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_pinv_${ri}$_operator(a) result(pinva)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> Result pseudo-inverse matrix
${rt}$ :: pinva(size(a,2,kind=ilp),size(a,1,kind=ilp))
end function stdlib_linalg_pinv_${ri}$_operator
#:endfor
end interface operator(.pinv.)
! Eigendecomposition of a square matrix: eigenvalues, and optionally eigenvectors
interface eig
!! version: experimental
!!
!! Solves the eigendecomposition \( A \cdot \bar{v} - \lambda \cdot \bar{v} \) for square matrix \( A \).
!! ([Specification](../page/specs/stdlib_linalg.html#eig-eigenvalues-and-eigenvectors-of-a-square-matrix))
!!
!!### Summary
!! Subroutine interface for computing eigenvalues and eigenvectors of a square matrix.
!!
!!### Description
!!
!! This interface provides methods for computing the eigenvalues, and optionally eigenvectors,
!! of a general square matrix. Supported data types include `real` and `complex`, and no assumption is
!! made on the matrix structure. The user may request either left, right, or both
!! eigenvectors to be returned. They are returned as columns of a square matrix with the same size as `A`.
!! Preallocated space for both eigenvalues `lambda` and the eigenvector matrices must be user-provided.
!!
!!@note The solution is based on LAPACK's general eigenproblem solvers `*GEEV`.
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
!!
#:for rk,rt,ri in RC_KINDS_TYPES
#:for ep,ei in EIG_PROBLEM_LIST
module subroutine stdlib_linalg_eig_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#,lambda,right,left, &
overwrite_a#{if ei=='ggev'}#,overwrite_b#{endif}#,err)
!! Eigendecomposition of matrix A returning an array `lambda` of eigenvalues,
!! and optionally right or left eigenvectors.
!> Input matrix A[m,n]
${rt}$, intent(inout), target :: a(:,:)
#:if ei=='ggev'
!> Generalized problem matrix B[n,n]
${rt}$, intent(inout), target :: b(:,:)
#:endif
!> Array of eigenvalues
complex(${rk}$), intent(out) :: lambda(:)
!> The columns of RIGHT contain the right eigenvectors of A
complex(${rk}$), optional, intent(out), target :: right(:,:)
!> The columns of LEFT contain the left eigenvectors of A
complex(${rk}$), optional, intent(out), target :: left(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
#:if ei=='ggev'
!> [optional] Can B data be overwritten and destroyed? (default: no)
logical(lk), optional, intent(in) :: overwrite_b
#:endif
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_eig_${ep}$_${ri}$
module subroutine stdlib_linalg_real_eig_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#,lambda,right,left, &
overwrite_a#{if ei=='ggev'}#,overwrite_b#{endif}#,err)
!! Eigendecomposition of matrix A returning an array `lambda` of real eigenvalues,
!! and optionally right or left eigenvectors. Returns an error if the eigenvalues had
!! non-trivial imaginary parts.
!> Input matrix A[m,n]
${rt}$, intent(inout), target :: a(:,:)
#:if ei=='ggev'
!> Generalized problem matrix B[n,n]
${rt}$, intent(inout), target :: b(:,:)
#:endif
!> Array of real eigenvalues
real(${rk}$), intent(out) :: lambda(:)
!> The columns of RIGHT contain the right eigenvectors of A
complex(${rk}$), optional, intent(out), target :: right(:,:)
!> The columns of LEFT contain the left eigenvectors of A
complex(${rk}$), optional, intent(out), target :: left(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
#:if ei=='ggev'
!> [optional] Can B data be overwritten and destroyed? (default: no)
logical(lk), optional, intent(in) :: overwrite_b
#:endif
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_real_eig_${ep}$_${ri}$
#:endfor
#:endfor
end interface eig
! Eigenvalues of a square matrix
interface eigvals
!! version: experimental
!!
!! Returns the eigenvalues \( lambda \), \( A \cdot \bar{v} - \lambda \cdot \bar{v} \), for square matrix \( A \).
!! ([Specification](../page/specs/stdlib_linalg.html#eigvals-eigenvalues-of-a-square-matrix))
!!
!!### Summary
!! Function interface for computing the eigenvalues of a square matrix.
!!
!!### Description
!!
!! This interface provides functions for returning the eigenvalues of a general square matrix.
!! Supported data types include `real` and `complex`, and no assumption is made on the matrix structure.
!! An `error stop` is thrown in case of failure; otherwise, error information can be returned
!! as an optional `type(linalg_state_type)` output flag.
!!
!!@note The solution is based on LAPACK's general eigenproblem solvers `*GEEV`.
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
!!
#:for rk,rt,ri in RC_KINDS_TYPES
#:for ep,ei in EIG_PROBLEM_LIST
module function stdlib_linalg_eigvals_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#,err) result(lambda)
!! Return an array of eigenvalues of matrix A.
!> Input matrix A[m,n]
${rt}$, intent(in), dimension(:,:), target :: a
#:if ei=='ggev'
!> Generalized problem matrix B[n,n]
${rt}$, intent(inout), dimension(:,:), target :: b
#:endif
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out) :: err
!> Array of singular values
complex(${rk}$), allocatable :: lambda(:)
end function stdlib_linalg_eigvals_${ep}$_${ri}$
module function stdlib_linalg_eigvals_noerr_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#) result(lambda)
!! Return an array of eigenvalues of matrix A.
!> Input matrix A[m,n]
${rt}$, intent(in), dimension(:,:), target :: a
#:if ei=='ggev'
!> Generalized problem matrix B[n,n]
${rt}$, intent(inout), dimension(:,:), target :: b
#:endif
!> Array of singular values
complex(${rk}$), allocatable :: lambda(:)
end function stdlib_linalg_eigvals_noerr_${ep}$_${ri}$
#:endfor
#:endfor
end interface eigvals
! Eigendecomposition of a real symmetric or complex hermitian matrix
interface eigh
!! version: experimental
!!
!! Solves the eigendecomposition \( A \cdot \bar{v} - \lambda \cdot \bar{v} \) for a real symmetric
!! \( A = A^T \) or complex Hermitian \( A = A^H \) square matrix.
!! ([Specification](../page/specs/stdlib_linalg.html#eigh-eigenvalues-and-eigenvectors-of-a-real-symmetric-or-complex-hermitian-square-matrix))
!!
!!### Summary
!! Subroutine interface for computing eigenvalues and eigenvectors of a real symmetric or complex Hermitian square matrix.
!!
!!### Description
!!
!! This interface provides methods for computing the eigenvalues, and optionally eigenvectors,
!! of a real symmetric or complex Hermitian square matrix. Supported data types include `real` and `complex`.
!! The matrix must be symmetric (if `real`) or Hermitian (if `complex`). Only the lower or upper
!! half of the matrix is accessed, and the user can select which using the optional `upper_a`
!! flag (default: use lower half). The vectors are orthogonal, and may be returned as columns of an optional
!! matrix `vectors` with the same kind and size as `A`.
!! Preallocated space for both eigenvalues `lambda` and the eigenvector matrix must be user-provided.
!!
!!@note The solution is based on LAPACK's eigenproblem solvers `*SYEV`/`*HEEV`.
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_eigh_${ri}$(a,lambda,vectors,upper_a,overwrite_a,err)
!! Eigendecomposition of a real symmetric or complex Hermitian matrix A returning an array `lambda`
!! of eigenvalues, and optionally right or left eigenvectors.
!> Input matrix A[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> Array of eigenvalues
real(${rk}$), intent(out) :: lambda(:)
!> The columns of vectors contain the orthonormal eigenvectors of A
${rt}$, optional, intent(out), target :: vectors(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Should the upper/lower half of A be used? Default: lower
logical(lk), optional, intent(in) :: upper_a
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_eigh_${ri}$
#:endfor
end interface eigh
! Eigenvalues of a real symmetric or complex hermitian matrix
interface eigvalsh
!! version: experimental
!!
!! Returns the eigenvalues \( lambda \), \( A \cdot \bar{v} - \lambda \cdot \bar{v} \), for a real
!! symmetric \( A = A^T \) or complex Hermitian \( A = A^H \) square matrix.
!! ([Specification](../page/specs/stdlib_linalg.html#eigvalsh-eigenvalues-of-a-real-symmetric-or-complex-hermitian-square-matrix))
!!
!!### Summary
!! Function interface for computing the eigenvalues of a real symmetric or complex hermitian square matrix.
!!
!!### Description
!!
!! This interface provides functions for returning the eigenvalues of a real symmetric or complex Hermitian
!! square matrix. Supported data types include `real` and `complex`. The matrix must be symmetric
!! (if `real`) or Hermitian (if `complex`). Only the lower or upper half of the matrix is accessed,
!! and the user can select which using the optional `upper_a` flag (default: use lower half).
!! An `error stop` is thrown in case of failure; otherwise, error information can be returned
!! as an optional `type(linalg_state_type)` output flag.
!!
!!@note The solution is based on LAPACK's eigenproblem solvers `*SYEV`/`*HEEV`.
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_eigvalsh_${ri}$(a,upper_a,err) result(lambda)
!! Return an array of eigenvalues of real symmetric / complex hermitian A
!> Input matrix A[m,n]
${rt}$, intent(in), target :: a(:,:)
!> [optional] Should the upper/lower half of A be used? Default: lower
logical(lk), optional, intent(in) :: upper_a
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out) :: err
!> Array of singular values
real(${rk}$), allocatable :: lambda(:)
end function stdlib_linalg_eigvalsh_${ri}$
module function stdlib_linalg_eigvalsh_noerr_${ri}$(a,upper_a) result(lambda)
!! Return an array of eigenvalues of real symmetric / complex hermitian A
!> Input matrix A[m,n]
${rt}$, intent(in), target :: a(:,:)
!> [optional] Should the upper/lower half of A be used? Default: lower
logical(lk), optional, intent(in) :: upper_a
!> Array of singular values
real(${rk}$), allocatable :: lambda(:)
end function stdlib_linalg_eigvalsh_noerr_${ri}$
#:endfor
end interface eigvalsh
! Singular value decomposition
interface svd
!! version: experimental
!!
!! Computes the singular value decomposition of a `real` or `complex` 2d matrix.
!! ([Specification](../page/specs/stdlib_linalg.html#svd-compute-the-singular-value-decomposition-of-a-rank-2-array-matrix))
!!
!!### Summary
!! Interface for computing the singular value decomposition of a `real` or `complex` 2d matrix.
!!
!!### Description
!!
!! This interface provides methods for computing the singular value decomposition of a matrix.
!! Supported data types include `real` and `complex`. The subroutine returns a `real` array of
!! singular values, and optionally, left- and right- singular vector matrices, `U` and `V`.
!! For a matrix `A` with size [m,n], full matrix storage for `U` and `V` should be [m,m] and [n,n].
!! It is possible to use partial storage [m,k] and [k,n], `k=min(m,n)`, choosing `full_matrices=.false.`.
!!
!!@note The solution is based on LAPACK's singular value decomposition `*GESDD` methods.
!!
!!### Example
!!
!!```fortran
!! real(sp) :: a(2,3), s(2), u(2,2), vt(3,3)
!! a = reshape([3,2, 2,3, 2,-2],[2,3])
!!
!! call svd(A,s,u,v)
!! print *, 'singular values = ',s
!!```
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_svd_${ri}$(a,s,u,vt,overwrite_a,full_matrices,err)
!!### Summary
!! Compute singular value decomposition of a matrix \( A = U \cdot S \cdot \V^T \)
!!
!!### Description
!!
!! This function computes the singular value decomposition of a `real` or `complex` matrix \( A \),
!! and returns the array of singular values, and optionally the left matrix \( U \) containing the
!! left unitary singular vectors, and the right matrix \( V^T \), containing the right unitary
!! singular vectors.
!!
!! param: a Input matrix of size [m,n].
!! param: s Output `real` array of size [min(m,n)] returning a list of singular values.
!! param: u [optional] Output left singular matrix of size [m,m] or [m,min(m,n)] (.not.full_matrices). Contains singular vectors as columns.
!! param: vt [optional] Output right singular matrix of size [n,n] or [min(m,n),n] (.not.full_matrices). Contains singular vectors as rows.
!! param: overwrite_a [optional] Flag indicating if the input matrix can be overwritten.
!! param: full_matrices [optional] If `.true.` (default), matrices \( U \) and \( V^T \) have size [m,m], [n,n]. Otherwise, they are [m,k], [k,n] with `k=min(m,n)`.
!! param: err [optional] State return flag.
!!
!> Input matrix A[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> Array of singular values
real(${rk}$), intent(out) :: s(:)
!> The columns of U contain the left singular vectors
${rt}$, optional, intent(out), target :: u(:,:)
!> The rows of V^T contain the right singular vectors
${rt}$, optional, intent(out), target :: vt(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] full matrices have shape(u)==[m,m], shape(vh)==[n,n] (default); otherwise
!> they are shape(u)==[m,k] and shape(vh)==[k,n] with k=min(m,n)
logical(lk), optional, intent(in) :: full_matrices
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_svd_${ri}$
#:endfor
end interface svd
! Singular values
interface svdvals
!! version: experimental
!!
!! Computes the singular values of a `real` or `complex` 2d matrix.
!! ([Specification](../page/specs/stdlib_linalg.html#svdvals-compute-the-singular-values-of-a-rank-2-array-matrix))
!!
!!### Summary
!!
!! Function interface for computing the array of singular values from the singular value decomposition
!! of a `real` or `complex` 2d matrix.
!!
!!### Description
!!
!! This interface provides methods for computing the singular values a 2d matrix.
!! Supported data types include `real` and `complex`. The function returns a `real` array of
!! singular values, with size [min(m,n)].
!!
!!@note The solution is based on LAPACK's singular value decomposition `*GESDD` methods.
!!
!!### Example
!!
!!```fortran
!! real(sp) :: a(2,3), s(2)
!! a = reshape([3,2, 2,3, 2,-2],[2,3])
!!
!! s = svdvals(A)
!! print *, 'singular values = ',s
!!```
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_svdvals_${ri}$(a,err) result(s)
!!### Summary
!! Compute singular values \(S \) from the singular-value decomposition of a matrix \( A = U \cdot S \cdot \V^T \).
!!
!!### Description
!!
!! This function returns the array of singular values from the singular value decomposition of a `real`
!! or `complex` matrix \( A = U \cdot S \cdot V^T \).
!!
!! param: a Input matrix of size [m,n].
!! param: err [optional] State return flag.
!!
!!### Return value
!!
!! param: s `real` array of size [min(m,n)] returning a list of singular values.
!!
!> Input matrix A[m,n]
${rt}$, intent(in), target :: a(:,:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Array of singular values
real(${rk}$), allocatable :: s(:)
end function stdlib_linalg_svdvals_${ri}$
#:endfor
end interface svdvals
#! Allow for integer or character norm input: i.e., norm(a,2) or norm(a, '2')
#:set NORM_INPUT_TYPE = ["character(len=*)","integer(ilp)"]
#:set NORM_INPUT_SHORT = ["char","int"]
#:set NORM_INPUT_OPTIONS = list(zip(NORM_INPUT_TYPE,NORM_INPUT_SHORT))
! Vector norms: function interface
interface norm
!! version: experimental
!!
!! Computes the vector norm of a generic-rank array \( A \).
!! ([Specification](../page/specs/stdlib_linalg.html#norm-computes-the-vector-norm-of-a-generic-rank-array))
!!
!!### Summary
!! Return one of several scalar norm metrics of a `real` or `complex` input array \( A \),
!! that can have any rank. For generic rank-n arrays, the scalar norm over the whole
!! array is returned by default. If `n>=2` and the optional input dimension `dim` is specified,
!! a rank `n-1` array is returned with dimension `dim` collapsed, containing all 1D array norms
!! evaluated along dimension `dim` only.
!!
!!
!!### Description
!!
!! This interface provides methods for computing the vector norm(s) of an array.
!! Supported data types include `real` and `complex`.
!! Input arrays may have generic rank from 1 to ${MAXRANK}$.
!!
!! Norm type input is mandatory, and it is provided via the `order` argument.
!! This can be provided as either an `integer` value or a `character` string.
!! Allowed metrics are:
!! - 1-norm \( \sum_i{ \left|a_i\right| } \): `order` = 1 or '1'
!! - Euclidean norm \( \sqrt{\sum_i{ a_i^2 }} \): `order` = 2 or '2'
!! - p-norm \( \left( \sum_i{ \left|a_i\right|^p }\right) ^{1/p} \): `integer` `order`, order>=3
!! - Infinity norm \( \max_i{ \left|a_i\right| } \): order = huge(0) or 'inf'
!! - Minus-infinity norm \( \min_i{ \left|a_i\right| } \): order = -huge(0) or '-inf'
!!
!!### Example
!!
!!```fortran
!!
!! real(sp) :: a(3,3), na, rown(3)
!! a = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!!
!! ! L2 norm: whole matrix
!! na = norm(a, 2)
!!
!! ! Infinity norm of each row
!! rown = norm(a, 'inf', dim=2)
!!
!!```
!!
#:for rk,rt,ri in RC_KINDS_TYPES
#:for it,ii in NORM_INPUT_OPTIONS
!> Scalar norms: ${rt}$
#:for rank in range(1, MAXRANK + 1)
pure module function stdlib_linalg_norm_${rank}$D_order_${ii}$_${ri}$(a, order) result(nrm)
!> Input ${rank}$-d matrix a${ranksuffix(rank)}$
${rt}$, intent(in) :: a${ranksuffix(rank)}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> Norm of the matrix.
real(${rk}$) :: nrm
end function stdlib_linalg_norm_${rank}$D_order_${ii}$_${ri}$
module function stdlib_linalg_norm_${rank}$D_order_err_${ii}$_${ri}$(a, order, err) result(nrm)
!> Input ${rank}$-d matrix a${ranksuffix(rank)}$
${rt}$, intent(in) :: a${ranksuffix(rank)}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> Output state return flag.
type(linalg_state_type), intent(out) :: err
!> Norm of the matrix.
real(${rk}$) :: nrm
end function stdlib_linalg_norm_${rank}$D_order_err_${ii}$_${ri}$
#:endfor
!> Array norms: ${rt}$
#:for rank in range(2, MAXRANK + 1)
pure module function stdlib_linalg_norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$(a, order, dim) result(nrm)
!> Input matrix a[..]
${rt}$, intent(in), target :: a${ranksuffix(rank)}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> Dimension the norm is computed along
integer(ilp), intent(in) :: dim
!> Norm of the matrix. (Same shape as `a`, with `dim` dropped).
real(${rk}$) :: nrm${reduced_shape('a', rank, 'dim')}$
end function stdlib_linalg_norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$
module function stdlib_linalg_norm_${rank}$D_to_${rank-1}$D_err_${ii}$_${ri}$(a, order, dim, err) result(nrm)
!> Input matrix a[..]
${rt}$, intent(in), target :: a${ranksuffix(rank)}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> Dimension the norm is computed along
integer(ilp), intent(in) :: dim
!> Output state return flag.
type(linalg_state_type), intent(out) :: err
!> Norm of the matrix. (Same shape as `a`, with `dim` dropped).
real(${rk}$) :: nrm${reduced_shape('a', rank, 'dim')}$
end function stdlib_linalg_norm_${rank}$D_to_${rank-1}$D_err_${ii}$_${ri}$
#:endfor
#:endfor
#:endfor
end interface norm
!> Vector norm: subroutine interface
interface get_norm
!! version: experimental
!!
!! Computes the vector norm of a generic-rank array \( A \).
!! ([Specification](../page/specs/stdlib_linalg.html#get-norm-computes-the-vector-norm-of-a-generic-rank-array))
!!
!!### Summary
!! Subroutine interface that returns one of several scalar norm metrics of a `real` or `complex`
!! input array \( A \), that can have any rank. For generic rank-n arrays, the scalar norm over
!! the whole array is returned by default. If `n>=2` and the optional input dimension `dim` is
!! specified, a rank `n-1` array is returned with dimension `dim` collapsed, containing all 1D
!! array norms evaluated along dimension `dim` only.
!!
!!
!!### Description
!!
!! This `pure subroutine `interface provides methods for computing the vector norm(s) of an array.
!! Supported data types include `real` and `complex`.
!! Input arrays may have generic rank from 1 to ${MAXRANK}$.
!!
!! Norm type input is mandatory, and it is provided via the `order` argument.
!! This can be provided as either an `integer` value or a `character` string.
!! Allowed metrics are:
!! - 1-norm \( \sum_i{ \left|a_i\right| } \): `order` = 1 or '1'
!! - Euclidean norm \( \sqrt{\sum_i{ a_i^2 }} \): `order` = 2 or '2'
!! - p-norm \( \left( \sum_i{ \left|a_i\right|^p }\right) ^{1/p} \): `integer` `order`, order>=3
!! - Infinity norm \( \max_i{ \left|a_i\right| } \): order = huge(0) or 'inf'
!! - Minus-infinity norm \( \min_i{ \left|a_i\right| } \): order = -huge(0) or '-inf'
!!
!!### Example
!!
!!```fortran
!!
!! real(sp) :: a(3,3), na, rown(3)
!! type(linalg_state_type) :: err
!! a = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!!
!! ! L2 norm: whole matrix
!! call get_norm(a, na, 2)
!!
!! ! Infinity norms of each row, with error control
!! call get_norm(a, rown, 'inf', dim=2, err=err)
!!
!!```
!!
#:for rk,rt,ri in RC_KINDS_TYPES
#:for it,ii in NORM_INPUT_OPTIONS
!> Scalar norms: ${rt}$
#:for rank in range(1, MAXRANK + 1)
pure module subroutine norm_${rank}$D_${ii}$_${ri}$(a, nrm, order, err)
!> Input ${rank}$-d matrix a${ranksuffix(rank)}$
${rt}$, intent(in), target :: a${ranksuffix(rank)}$
!> Norm of the matrix.
real(${rk}$), intent(out) :: nrm
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out), optional :: err
end subroutine norm_${rank}$D_${ii}$_${ri}$
#:endfor
!> Array norms: ${rt}$
#:for rank in range(2, MAXRANK + 1)
pure module subroutine norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$(a, nrm, order, dim, err)
!> Input matrix a[..]
${rt}$, intent(in) :: a${ranksuffix(rank)}$
!> Dimension the norm is computed along
integer(ilp), intent(in) :: dim
!> Norm of the matrix. (Same shape as `a`, with `dim` dropped).
real(${rk}$), intent(out) :: nrm${reduced_shape('a', rank, 'dim')}$
!> Order of the matrix norm being computed.
${it}$, intent(in) :: order
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out), optional :: err
end subroutine norm_${rank}$D_to_${rank-1}$D_${ii}$_${ri}$
#:endfor
#:endfor
#:endfor
end interface get_norm
!> Matrix norms: function interface
interface mnorm
!! version: experimental
!!
!! Computes the matrix norm of a generic-rank array \( A \).
!! ([Specification](../page/specs/stdlib_linalg.html#mnorm-computes-the-matrix-norm-of-a-generic-rank-array))
!!
!!### Summary
!! Return one of several matrix norm metrics of a `real` or `complex` input array \( A \),
!! that can have rank 2 or higher. For rank-2 arrays, the matrix norm is returned.
!! If rank>2 and the optional input dimensions `dim` are specified,
!! a rank `n-2` array is returned with dimensions `dim(1),dim(2)` collapsed, containing all
!! matrix norms evaluated over the specified dimensions only. `dim==[1,2]` are assumed as default
!! dimensions if not specified.
!!
!!### Description
!!
!! This interface provides methods for computing the matrix norm(s) of an array.
!! Supported data types include `real` and `complex`.
!! Input arrays must have rank >= 2.
!!
!! Norm type input is optional, and it is provided via the `order` argument.
!! This can be provided as either an `integer` value or a `character` string.
!! Allowed metrics are:
!! - 1-norm: `order` = 1 or '1'
!! - 2-norm: `order` = 2 or '2'
!! - Euclidean/Frobenius: `order` = 'Euclidean','Frobenius', or argument not specified
!! - Infinity norm: `order` = huge(0) or 'Inf'
!!
!! If an invalid norm type is provided, the routine returns an error state.
!!
!!### Example
!!
!!```fortran
!! real(sp) :: a(3,3), na
!! real(sp) :: b(3,3,4), nb(4) ! Array of 4 3x3 matrices
!! a = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!!
!! ! Euclidean/Frobenius norm of single matrix
!! na = mnorm(a)
!! na = mnorm(a, 'Euclidean')
!!
!! ! 1-norm of each 3x3 matrix in b
!! nb = mnorm(b, 1, dim=[1,2])
!!
!! ! Infinity-norm
!! na = mnorm(b, 'inf', dim=[3,2])
!!```
!!
#:for rk,rt,ri in RC_KINDS_TYPES
#:for it,ii in NORM_INPUT_OPTIONS
!> Matrix norms: ${rt}$ rank-2 arrays
module function matrix_norm_${ii}$_${ri}$(a, order, err) result(nrm)
!> Input matrix a(m,n)
${rt}$, intent(in), target :: a(:,:)
!> Norm of the matrix.
real(${rk}$) :: nrm
!> Order of the matrix norm being computed.
${it}$, #{if 'integer' in it}#optional, #{endif}#intent(in) :: order
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out), optional :: err
end function matrix_norm_${ii}$_${ri}$
!> Matrix norms: ${rt}$ higher rank arrays
#:for rank in range(3, MAXRANK + 1)
module function matrix_norm_${rank}$D_to_${rank-2}$D_${ii}$_${ri}$(a, order, dim, err) result(nrm)
!> Input matrix a(m,n)
${rt}$, intent(in), contiguous, target :: a${ranksuffix(rank)}$
!> Norm of the matrix.
real(${rk}$), allocatable :: nrm${ranksuffix(rank-2)}$
!> Order of the matrix norm being computed.
${it}$, #{if 'integer' in it}#optional, #{endif}#intent(in) :: order
!> [optional] dimensions of the sub-matrices the norms should be evaluated at (default = [1,2])
integer(ilp), optional, intent(in) :: dim(2)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out), optional :: err
end function matrix_norm_${rank}$D_to_${rank-2}$D_${ii}$_${ri}$
#:endfor
#:endfor
#:endfor
end interface mnorm
!> Matrix exponential: function interface
interface expm
!! version : experimental
!!
!! Computes the exponential of a matrix using a rational Pade approximation.
!! ([Specification](../page/specs/stdlib_linalg.html#expm))
!!
!! ### Description
!!
!! This interface provides methods for computing the exponential of a matrix
!! represented as a standard Fortran rank-2 array. Supported data types include
!! `real` and `complex`.
!!
!! By default, the order of the Pade approximation is set to 10. It can be changed
!! via the `order` argument that must be non-negative.
!!
!! If the input matrix is non-square or the order of the Pade approximation is
!! negative, the function returns an error state.
!!
!! ### Example
!!
!! ```fortran
!! real(dp) :: A(3, 3), E(3, 3)
!!
!! A = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!!
!! ! Default Pade approximation of the matrix exponential.
!! E = expm(A)
!!
!! ! Pade approximation with specified order.
!! E = expm(A, order=12)
!! ```
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module function stdlib_linalg_${ri}$_expm_fun(A, order) result(E)
!> Input matrix a(:, :).
${rt}$, intent(in) :: A(:, :)
!> [optional] Order of the Pade approximation (default `order=10`)
integer(ilp), optional, intent(in) :: order
!> Exponential of the input matrix E = exp(A).
${rt}$, allocatable :: E(:, :)
end function stdlib_linalg_${ri}$_expm_fun
#:endfor
end interface expm
!> Matrix exponential: subroutine interface
interface matrix_exp
!! version : experimental
!!
!! Computes the exponential of a matrix using a rational Pade approximation.
!! ([Specification](../page/specs/stdlib_linalg.html#matrix_exp))
!!
!! ### Description
!!
!! This interface provides methods for computing the exponential of a matrix
!! represented as a standard Fortran rank-2 array. Supported data types include
!! `real` and `complex`.
!!
!! By default, the order of the Pade approximation is set to 10. It can be changed
!! via the `order` argument that must be non-negative.
!!
!! If the input matrix is non-square or the order of the Pade approximation is
!! negative, the function returns an error state.
!!
!! ### Example
!!
!! ```fortran
!! real(dp) :: A(3, 3), E(3, 3)
!!
!! A = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
!!
!! ! Default Pade approximation of the matrix exponential.
!! call matrix_exp(A, E) ! Out-of-place
!! ! call matrix_exp(A) for in-place computation.
!!
!! ! Pade approximation with specified order.
!! call matrix_exp(A, E, order=12)
!! ```
!!
#:for rk,rt,ri in RC_KINDS_TYPES
module subroutine stdlib_linalg_${ri}$_expm_inplace(A, order, err)
!> Input matrix A(n, n) / Output matrix E = exp(A)
${rt}$, intent(inout) :: A(:, :)
!> [optional] Order of the Pade approximation (default `order=10`)
integer(ilp), optional, intent(in) :: order
!> [optional] Error handling.
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_expm_inplace
module subroutine stdlib_linalg_${ri}$_expm(A, E, order, err)
!> Input matrix A(n, n)
${rt}$, intent(in) :: A(:, :)
!> Output matrix exponential E = exp(A)
${rt}$, intent(out) :: E(:, :)
!> [optional] Order of the Pade approximation (default `order=10`)
integer(ilp), optional, intent(in) :: order
!> [optional] Error handling.
type(linalg_state_type), optional, intent(out) :: err
end subroutine stdlib_linalg_${ri}$_expm
#:endfor
end interface matrix_exp
contains
!> Version: experimental
!>
!> Constructs the identity matrix.
!> ([Specification](../page/specs/stdlib_linalg.html#eye-construct-the-identity-matrix))
#:for k1, t1 in RCI_KINDS_TYPES
pure function eye_${t1[0]}$${k1}$(dim1, dim2, mold) result(result)
integer, intent(in) :: dim1
integer, intent(in), optional :: dim2
${t1}$, intent(in) #{if t1 == 'real(dp)'}#, optional #{endif}#:: mold
${t1}$, allocatable :: result(:, :)
integer :: dim2_
integer :: i
dim2_ = optval(dim2, dim1)
allocate(result(dim1, dim2_))
result = 0
do i = 1, min(dim1, dim2_)
result(i, i) = 1
end do
end function eye_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
function trace_${t1[0]}$${k1}$(A) result(res)
${t1}$, intent(in) :: A(:,:)
${t1}$ :: res
integer :: i
res = 0
do i = 1, minval(shape(A))
res = res + A(i,i)
end do
end function trace_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
pure function is_square_${t1[0]}$${k1}$(A) result(res)
${t1}$, intent(in) :: A(:,:)
logical :: res
res = (size(A,1) == size(A,2))
end function is_square_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
pure function is_diagonal_${t1[0]}$${k1}$(A) result(res)
${t1}$, intent(in) :: A(:,:)
logical :: res
${t1}$, parameter :: zero = 0 !zero of relevant type
integer :: m, n, o, i, j
m = size(A,1)
n = size(A,2)
do j = 1, n !loop over all columns
o = min(j-1,m) !index of row above diagonal (or last row)
do i = 1, o !loop over rows above diagonal
if (A(i,j) /= zero) then
res = .false.
return
end if
end do
do i = o+2, m !loop over rows below diagonal
if (A(i,j) /= zero) then
res = .false.
return
end if
end do
end do
res = .true. !otherwise A is diagonal
end function is_diagonal_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
pure function is_symmetric_${t1[0]}$${k1}$(A) result(res)
${t1}$, intent(in) :: A(:,:)
logical :: res
integer :: n, i, j
if (.not. is_square(A)) then
res = .false.
return !nonsquare matrices cannot be symmetric
end if
n = size(A,1) !symmetric dimension of A
do j = 1, n !loop over all columns
do i = 1, j-1 !loop over all rows above diagonal
if (A(i,j) /= A(j,i)) then
res = .false.
return
end if
end do
end do
res = .true. !otherwise A is symmetric
end function is_symmetric_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
pure function is_skew_symmetric_${t1[0]}$${k1}$(A) result(res)
${t1}$, intent(in) :: A(:,:)
logical :: res
integer :: n, i, j
if (.not. is_square(A)) then
res = .false.
return !nonsquare matrices cannot be skew-symmetric
end if
n = size(A,1) !symmetric dimension of A
do j = 1, n !loop over all columns
do i = 1, j !loop over all rows above diagonal (and diagonal)
if (A(i,j) /= -A(j,i)) then
res = .false.
return
end if
end do
end do
res = .true. !otherwise A is skew-symmetric
end function is_skew_symmetric_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in (REAL_KINDS_TYPES + INT_KINDS_TYPES)
pure function is_hermitian_${t1[0]}$${k1}$(A) result(res)
${t1}$, intent(in) :: A(:,:)
logical :: res
res = is_symmetric(A) !symmetry and Hermiticity are equivalent for real matrices
end function is_hermitian_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
pure function is_hermitian_${t1[0]}$${k1}$(A) result(res)
${t1}$, intent(in) :: A(:,:)
logical :: res
integer :: n, i, j
if (.not. is_square(A)) then
res = .false.
return !nonsquare matrices cannot be Hermitian
end if
n = size(A,1) !symmetric dimension of A
do j = 1, n !loop over all columns
do i = 1, j !loop over all rows above diagonal (and diagonal)
if (A(i,j) /= conjg(A(j,i))) then
res = .false.
return
end if
end do
end do
res = .true. !otherwise A is Hermitian
end function is_hermitian_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
pure module function hermitian_${t1[0]}$${k1}$(a) result(ah)
${t1}$, intent(in) :: a(:,:)
${t1}$ :: ah(size(a, 2), size(a, 1))
#:if t1.startswith('complex')
ah = conjg(transpose(a))
#:else
ah = transpose(a)
#:endif
end function hermitian_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
function is_triangular_${t1[0]}$${k1}$(A,uplo) result(res)
${t1}$, intent(in) :: A(:,:)
character, intent(in) :: uplo
logical :: res
${t1}$, parameter :: zero = 0 !zero of relevant type
integer :: m, n, o, i, j
m = size(A,1)
n = size(A,2)
if ((uplo == 'u') .or. (uplo == 'U')) then !check for upper triangularity
do j = 1, n !loop over all columns
o = min(j-1,m) !index of row above diagonal (or last row)
do i = o+2, m !loop over rows below diagonal
if (A(i,j) /= zero) then
res = .false.
return
end if
end do
end do
else if ((uplo == 'l') .or. (uplo == 'L')) then !check for lower triangularity
do j=1,n !loop over all columns
o = min(j-1,m) !index of row above diagonal (or last row)
do i=1,o !loop over rows above diagonal
if (A(i,j) /= zero) then
res = .false.
return
end if
end do
end do
else
call error_stop("ERROR (is_triangular): second argument must be one of {'u','U','l','L'}")
end if
res = .true. !otherwise A is triangular of the requested type
end function is_triangular_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in RCI_KINDS_TYPES
function is_hessenberg_${t1[0]}$${k1}$(A,uplo) result(res)
${t1}$, intent(in) :: A(:,:)
character, intent(in) :: uplo
logical :: res
${t1}$, parameter :: zero = 0 !zero of relevant type
integer :: m, n, o, i, j
m = size(A,1)
n = size(A,2)
if ((uplo == 'u') .or. (uplo == 'U')) then !check for upper Hessenberg
do j = 1, n !loop over all columns
o = min(j-2,m) !index of row two above diagonal (or last row)
do i = o+4, m !loop over rows two or more below main diagonal
if (A(i,j) /= zero) then
res = .false.
return
end if
end do
end do
else if ((uplo == 'l') .or. (uplo == 'L')) then !check for lower Hessenberg
do j = 1, n !loop over all columns
o = min(j-2,m) !index of row two above diagonal (or last row)
do i = 1, o !loop over rows one or more above main diagonal
if (A(i,j) /= zero) then
res = .false.
return
end if
end do
end do
else
call error_stop("ERROR (is_hessenberg): second argument must be one of {'u','U','l','L'}")
end if
res = .true. !otherwise A is Hessenberg of the requested type
end function is_hessenberg_${t1[0]}$${k1}$
#:endfor
end module stdlib_linalg
fortran-lang-stdlib-0ede301/src/linalg/CMakeLists.txt 0000664 0001750 0001750 00000001664 15135654166 022772 0 ustar alastair alastair set(linalg_fppFiles
stdlib_linalg_cholesky.fypp
stdlib_linalg_cross_product.fypp
stdlib_linalg_determinant.fypp
stdlib_linalg_diag.fypp
stdlib_linalg_eigenvalues.fypp
stdlib_linalg.fypp
stdlib_linalg_inverse.fypp
stdlib_linalg_kronecker.fypp
stdlib_linalg_least_squares.fypp
stdlib_linalg_matrix_functions.fypp
stdlib_linalg_norms.fypp
stdlib_linalg_outer_product.fypp
stdlib_linalg_pinv.fypp
stdlib_linalg_qr.fypp
stdlib_linalg_schur.fypp
stdlib_linalg_solve.fypp
stdlib_linalg_svd.fypp
)
set(linalg_cppFiles
)
set(linalg_f90Files
)
configure_stdlib_target(${PROJECT_NAME}_linalg linalg_f90Files linalg_fppFiles linalg_cppFiles)
target_link_libraries(${PROJECT_NAME}_linalg PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_linalg_core ${PROJECT_NAME}_constants ${PROJECT_NAME}_lapack ${PROJECT_NAME}_lapack_extended ${PROJECT_NAME}_sorting ${PROJECT_NAME}_intrinsics)
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_kronecker.fypp 0000664 0001750 0001750 00000001737 15135654166 026005 0 ustar alastair alastair #:include "common.fypp"
#:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES
submodule (stdlib_linalg) stdlib_linalg_kronecker
implicit none
contains
#:for k1, t1 in RCI_KINDS_TYPES
pure module function kronecker_product_${t1[0]}$${k1}$(A, B) result(C)
${t1}$, intent(in) :: A(:,:), B(:,:)
${t1}$ :: C(size(A,dim=1)*size(B,dim=1),size(A,dim=2)*size(B,dim=2))
integer :: m1, n1, maxM1, maxN1, maxM2, maxN2
maxM1 = size(A, dim=1)
maxN1 = size(A, dim=2)
maxM2 = size(B, dim=1)
maxN2 = size(B, dim=2)
do n1 = 1, maxN1
do m1 = 1, maxM1
! We use the Wikipedia convention for ordering of the matrix elements
! https://en.wikipedia.org/wiki/Kronecker_product
C((m1-1)*maxM2+1:m1*maxM2, (n1-1)*maxN2+1:n1*maxN2) = A(m1, n1) * B(:,:)
end do
end do
end function kronecker_product_${t1[0]}$${k1}$
#:endfor
end submodule stdlib_linalg_kronecker
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_eigenvalues.fypp 0000664 0001750 0001750 00000062520 15135654166 026326 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set EIG_PROBLEM = ["standard", "generalized"]
#:set EIG_FUNCTION = ["geev","ggev"]
#:set EIG_PROBLEM_LIST = list(zip(EIG_PROBLEM, EIG_FUNCTION))
submodule (stdlib_linalg) stdlib_linalg_eigenvalues
!! Compute eigenvalues and eigenvectors
use stdlib_linalg_constants
use stdlib_linalg_lapack, only: geev, ggev, heev, syev
use stdlib_linalg_lapack_aux, only: handle_geev_info, handle_ggev_info, handle_heev_info
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR, LINALG_SUCCESS
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_positive_inf, ieee_quiet_nan
implicit none
character(*), parameter :: this = 'eigenvalues'
!> Utility function: Scale generalized eigenvalue
interface scale_general_eig
#:for rk,rt,ri in RC_KINDS_TYPES
module procedure scale_general_eig_${ri}$
#:endfor
end interface scale_general_eig
contains
!> Request for eigenvector calculation
elemental character function eigenvectors_task(required)
logical(lk), intent(in) :: required
eigenvectors_task = merge('V','N',required)
end function eigenvectors_task
!> Request for symmetry side (default: lower)
elemental character function symmetric_triangle_task(upper)
logical(lk), optional, intent(in) :: upper
symmetric_triangle_task = 'L'
if (present(upper)) symmetric_triangle_task = merge('U','L',upper)
end function symmetric_triangle_task
#:for rk,rt,ri in RC_KINDS_TYPES
#:for ep,ei in EIG_PROBLEM_LIST
module function stdlib_linalg_eigvals_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#,err) result(lambda)
!! Return an array of eigenvalues of matrix A.
!> Input matrix A[m,n]
${rt}$, intent(in), target :: a(:,:)
#:if ei=='ggev'
!> Generalized problem matrix B[n,n]
${rt}$, intent(inout), target :: b(:,:)
#:endif
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out) :: err
!> Array of eigenvalues
complex(${rk}$), allocatable :: lambda(:)
!> Create
${rt}$, pointer :: amat(:,:)#{if ei=='ggev'}#, bmat(:,:) #{endif}#
integer(ilp) :: m,n,k
!> Create an internal pointer so the intent of A won't affect the next call
amat => a
#{if ei=='ggev'}#bmat => b#{endif}#
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
!> Allocate return storage
allocate(lambda(k))
!> Compute eigenvalues only
call stdlib_linalg_eig_${ep}$_${ri}$(amat#{if ei=='ggev'}#,bmat#{endif}#,lambda,err=err)
end function stdlib_linalg_eigvals_${ep}$_${ri}$
module function stdlib_linalg_eigvals_noerr_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#) result(lambda)
!! Return an array of eigenvalues of matrix A.
!> Input matrix A[m,n]
${rt}$, intent(in), target :: a(:,:)
#:if ei=='ggev'
!> Generalized problem matrix B[n,n]
${rt}$, intent(inout), target :: b(:,:)
#:endif
!> Array of eigenvalues
complex(${rk}$), allocatable :: lambda(:)
!> Create
${rt}$, pointer :: amat(:,:)#{if ei=='ggev'}#, bmat(:,:) #{endif}#
integer(ilp) :: m,n,k
!> Create an internal pointer so the intent of A won't affect the next call
amat => a
#{if ei=='ggev'}#bmat => b#{endif}#
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
!> Allocate return storage
allocate(lambda(k))
!> Compute eigenvalues only
call stdlib_linalg_eig_${ep}$_${ri}$(amat#{if ei=='ggev'}#,bmat#{endif}#,lambda,overwrite_a=.false.)
end function stdlib_linalg_eigvals_noerr_${ep}$_${ri}$
module subroutine stdlib_linalg_eig_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#,lambda,right,left,&
overwrite_a#{if ei=='ggev'}#,overwrite_b#{endif}#,err)
!! Eigendecomposition of matrix A returning an array `lambda` of eigenvalues,
!! and optionally right or left eigenvectors.
!> Input matrix A[m,n]
${rt}$, intent(inout), target :: a(:,:)
#:if ei=='ggev'
!> Generalized problem matrix B[n,n]
${rt}$, intent(inout), target :: b(:,:)
#:endif
!> Array of eigenvalues
complex(${rk}$), intent(out) :: lambda(:)
!> [optional] RIGHT eigenvectors of A (as columns)
complex(${rk}$), optional, intent(out), target :: right(:,:)
!> [optional] LEFT eigenvectors of A (as columns)
complex(${rk}$), optional, intent(out), target :: left(:,:)
!> [optional] Can A data be overwritten and destroyed? (default: no)
logical(lk), optional, intent(in) :: overwrite_a
#:if ei=='ggev'
!> [optional] Can B data be overwritten and destroyed? (default: no)
logical(lk), optional, intent(in) :: overwrite_b
#:endif
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Local variables
type(linalg_state_type) :: err0
integer(ilp) :: m,n,lda,ldu,ldv,info,k,lwork,neig#{if ei=='ggev'}#,ldb,nb#{endif}#
logical(lk) :: copy_a#{if ei=='ggev'}#,copy_b#{endif}#
character :: task_u,task_v
${rt}$, target :: work_dummy(1),u_dummy(1,1),v_dummy(1,1)
${rt}$, allocatable :: work(:)
${rt}$, pointer :: amat(:,:),umat(:,:),vmat(:,:)#{if ei=='ggev'}#,bmat(:,:)#{endif}#
#:if rt.startswith('complex')
real(${rk}$), allocatable :: rwork(:)
#:else
${rt}$, pointer :: lreal(:),limag(:)
#:endif
#:if ei=='ggev'
${rt}$, allocatable :: beta(:)
#:endif
!> Matrix size
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
neig = size(lambda,kind=ilp)
lda = m
if (k<=0 .or. m/=n) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,&
'invalid or matrix size a=',[m,n],', must be nonempty square.')
call linalg_error_handling(err0,err)
return
elseif (neig b
endif
allocate(beta(n))
#:endif
! Decide if U, V eigenvectors
task_u = eigenvectors_task(present(left))
task_v = eigenvectors_task(present(right))
if (present(right)) then
#:if rt.startswith('complex')
! For a complex matrix, GEEV returns complex arrays.
! Point directly to output.
vmat => right
#:else
! For a real matrix, GEEV returns real arrays.
! Allocate temporary reals, will be converted to complex vectors at the end.
allocate(vmat(n,n))
#:endif
if (size(vmat,2,kind=ilp) left
#:else
! For a real matrix, GEEV returns real arrays.
! Allocate temporary reals, will be converted to complex vectors at the end.
allocate(umat(n,n))
#:endif
if (size(umat,2,kind=ilp) Prepare working storage
lwork = nint(real(work_dummy(1),kind=${rk}$), kind=ilp)
allocate(work(lwork))
!> Compute eigensystem
call ${ei}$(task_u,task_v,n,amat,lda,&
#:if ep=='generalized'
bmat,ldb, &
#:endif
#{if rt.startswith('complex')}#lambda,#{else}#lreal,limag,#{endif}# &
#:if ep=='generalized'
beta, &
#:endif
umat,ldu,vmat,ldv,&
work,lwork,#{if rt.startswith('complex')}#rwork,#{endif}#info)
call handle_${ei}$_info(this,err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
endif
! Finalize storage and process output flag
#:if not rt.startswith('complex')
lambda(:n) = cmplx(lreal(:n),limag(:n),kind=${rk}$)
#:endif
#:if ep=='generalized'
! Scale generalized eigenvalues
lambda(:n) = scale_general_eig(lambda(:n),beta)
#:endif
#:if not rt.startswith('complex')
! If the j-th and (j+1)-st eigenvalues form a complex conjugate pair,
! ${ei}$ returns reals as:
! u(j) = VL(:,j) + i*VL(:,j+1) and
! u(j+1) = VL(:,j) - i*VL(:,j+1).
! Convert these to complex numbers here.
if (present(right)) call assign_real_eigenvectors_${rk}$(n,lambda,vmat,right)
if (present(left)) call assign_real_eigenvectors_${rk}$(n,lambda,umat,left)
#:endif
endif get_${ei}$
if (copy_a) deallocate(amat)
#:if ep=='generalized'
if (copy_b) deallocate(bmat)
#:endif
#:if not rt.startswith('complex')
if (present(right)) deallocate(vmat)
if (present(left)) deallocate(umat)
#:endif
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_eig_${ep}$_${ri}$
#:endfor
module function stdlib_linalg_eigvalsh_${ri}$(a,upper_a,err) result(lambda)
!! Return an array of eigenvalues of real symmetric / complex hermitian A
!> Input matrix A[m,n]
${rt}$, intent(in), target :: a(:,:)
!> [optional] Should the upper/lower half of A be used? Default: lower
logical(lk), optional, intent(in) :: upper_a
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out) :: err
!> Array of eigenvalues
real(${rk}$), allocatable :: lambda(:)
${rt}$, pointer :: amat(:,:)
integer(ilp) :: m,n,k
!> Create an internal pointer so the intent of A won't affect the next call
amat => a
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
!> Allocate return storage
allocate(lambda(k))
!> Compute eigenvalues only
call stdlib_linalg_eigh_${ri}$(amat,lambda,upper_a=upper_a,err=err)
end function stdlib_linalg_eigvalsh_${ri}$
module function stdlib_linalg_eigvalsh_noerr_${ri}$(a,upper_a) result(lambda)
!! Return an array of eigenvalues of real symmetric / complex hermitian A
!> Input matrix A[m,n]
${rt}$, intent(in), target :: a(:,:)
!> [optional] Should the upper/lower half of A be used? Default: use lower
logical(lk), optional, intent(in) :: upper_a
!> Array of eigenvalues
real(${rk}$), allocatable :: lambda(:)
${rt}$, pointer :: amat(:,:)
integer(ilp) :: m,n,k
!> Create an internal pointer so the intent of A won't affect the next call
amat => a
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
!> Allocate return storage
allocate(lambda(k))
!> Compute eigenvalues only
call stdlib_linalg_eigh_${ri}$(amat,lambda,upper_a=upper_a,overwrite_a=.false.)
end function stdlib_linalg_eigvalsh_noerr_${ri}$
module subroutine stdlib_linalg_eigh_${ri}$(a,lambda,vectors,upper_a,overwrite_a,err)
!! Eigendecomposition of a real symmetric or complex Hermitian matrix A returning an array `lambda`
!! of eigenvalues, and optionally right or left eigenvectors.
!> Input matrix A[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> Array of eigenvalues
real(${rk}$), intent(out) :: lambda(:)
!> The columns of vectors contain the orthonormal eigenvectors of A
${rt}$, optional, intent(out), target :: vectors(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] Should the upper/lower half of A be used? Default: use lower
logical(lk), optional, intent(in) :: upper_a
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Local variables
type(linalg_state_type) :: err0
integer(ilp) :: m,n,lda,info,k,lwork,neig
logical(lk) :: copy_a
character :: triangle,task
${rt}$, target :: work_dummy(1)
${rt}$, allocatable :: work(:)
#:if rt.startswith('complex')
real(${rk}$), allocatable :: rwork(:)
#:endif
${rt}$, pointer :: amat(:,:)
!> Matrix size
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
neig = size(lambda,kind=ilp)
if (k<=0 .or. m/=n) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid or matrix size a=',[m,n], &
', must be non-empty square.')
call linalg_error_handling(err0,err)
return
elseif (neig= n=',n)
call linalg_error_handling(err0,err)
return
endif
! Check if input A can be overwritten
copy_a = .true._lk
if (present(vectors)) then
! No need to copy A anyways
copy_a = .false.
elseif (present(overwrite_a)) then
copy_a = .not.overwrite_a
endif
! Should we use the upper or lower half of the matrix?
triangle = symmetric_triangle_task(upper_a)
! Request for eigenvectors
task = eigenvectors_task(present(vectors))
if (present(vectors)) then
! Check size
if (any(shape(vectors,kind=ilp) Prepare working storage
lwork = nint(real(work_dummy(1),kind=${rk}$), kind=ilp)
allocate(work(lwork))
!> Compute eigensystem
#:if rt.startswith('complex')
call heev(task,triangle,n,amat,lda,lambda,work,lwork,rwork,info)
#:else
call syev(task,triangle,n,amat,lda,lambda,work,lwork,info)
#:endif
call handle_heev_info(this,err0,info,m,n)
endif
! Finalize storage and process output flag
if (copy_a) deallocate(amat)
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_eigh_${ri}$
#:endfor
#:for rk,rt,ri in REAL_KINDS_TYPES
pure subroutine assign_real_eigenvectors_${rk}$(n,lambda,lmat,out_mat)
!! GEEV for real matrices returns complex eigenvalues in real arrays, where two consecutive
!! reals at [j,j+1] locations represent the real and imaginary parts of two complex conjugate
!! eigenvalues. Convert them to complex here, following the GEEV logic.
!> Problem size
integer(ilp), intent(in) :: n
!> Array of eigenvalues
complex(${rk}$), intent(in) :: lambda(:)
!> Real matrix as returned by geev
${rt}$, intent(in) :: lmat(:,:)
!> Complex matrix as returned by eig
complex(${rk}$), intent(out) :: out_mat(:,:)
integer(ilp) :: i,j
! Copy matrix
do concurrent(i=1:n,j=1:n)
out_mat(i,j) = lmat(i,j)
end do
! If the j-th and (j+1)-st eigenvalues form a complex conjugate pair,
! geev returns them as reals as:
! u(j) = VL(:,j) + i*VL(:,j+1) and
! u(j+1) = VL(:,j) - i*VL(:,j+1).
! Convert these to complex numbers here.
do j=1,n-1
if (lambda(j)==conjg(lambda(j+1))) then
out_mat(:, j) = cmplx(lmat(:,j), lmat(:,j+1),kind=${rk}$)
out_mat(:,j+1) = cmplx(lmat(:,j),-lmat(:,j+1),kind=${rk}$)
endif
end do
end subroutine assign_real_eigenvectors_${rk}$
#:for ep,ei in EIG_PROBLEM_LIST
module subroutine stdlib_linalg_real_eig_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#,lambda,right,left, &
overwrite_a#{if ei=='ggev'}#,overwrite_b#{endif}#,err)
!! Eigendecomposition of matrix A returning an array `lambda` of real eigenvalues,
!! and optionally right or left eigenvectors. Returns an error if the eigenvalues had
!! non-trivial imaginary parts.
!> Input matrix A[m,n]
${rt}$, intent(inout), target :: a(:,:)
#:if ei=='ggev'
!> Generalized problem matrix B[n,n]
${rt}$, intent(inout), target :: b(:,:)
#:endif
!> Array of real eigenvalues
real(${rk}$), intent(out) :: lambda(:)
!> The columns of RIGHT contain the right eigenvectors of A
complex(${rk}$), optional, intent(out), target :: right(:,:)
!> The columns of LEFT contain the left eigenvectors of A
complex(${rk}$), optional, intent(out), target :: left(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
#:if ei=='ggev'
!> [optional] Can B data be overwritten and destroyed? (default: no)
logical(lk), optional, intent(in) :: overwrite_b
#:endif
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
type(linalg_state_type) :: err0
integer(ilp) :: n
complex(${rk}$), allocatable :: clambda(:)
real(${rk}$), parameter :: rtol = epsilon(0.0_${rk}$)
real(${rk}$), parameter :: atol = tiny(0.0_${rk}$)
n = size(lambda,dim=1,kind=ilp)
allocate(clambda(n))
call stdlib_linalg_eig_${ep}$_${ri}$(a#{if ei=='ggev'}#,b#{endif}#,clambda,right,left, &
overwrite_a#{if ei=='ggev'}#,overwrite_b#{endif}#,err0)
! Check that no eigenvalues have meaningful imaginary part
if (err0%ok() .and. any(aimag(clambda)>atol+rtol*abs(abs(clambda)))) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR, &
'complex eigenvalues detected: max(imag(lambda))=',maxval(aimag(clambda)))
endif
! Return real components only
lambda(:n) = real(clambda,kind=${rk}$)
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_real_eig_${ep}$_${ri}$
#:endfor
#:endfor
#:for rk,rt,ri in RC_KINDS_TYPES
!> Utility function: Scale generalized eigenvalue
elemental complex(${rk}$) function scale_general_eig_${ri}$(alpha,beta) result(lambda)
!! A generalized eigenvalue for a pair of matrices (A,B) is a scalar lambda or a ratio
!! alpha/beta = lambda, such that A - lambda*B is singular. It is usually represented as the
!! pair (alpha,beta), there is a reasonable interpretation for beta=0, and even for both
!! being zero.
complex(${rk}$), intent(in) :: alpha
${rt}$, intent(in) :: beta
real (${rk}$), parameter :: rzero = 0.0_${rk}$
complex(${rk}$), parameter :: czero = (0.0_${rk}$,0.0_${rk}$)
if (beta==#{if rt.startswith('real')}#r#{else}#c#{endif}#zero) then
if (alpha/=czero) then
lambda = cmplx(ieee_value(1.0_${rk}$, ieee_positive_inf), &
ieee_value(1.0_${rk}$, ieee_positive_inf), kind=${rk}$)
else
lambda = ieee_value(1.0_${rk}$, ieee_quiet_nan)
end if
else
lambda = alpha/beta
end if
end function scale_general_eig_${ri}$
#:endfor
end submodule stdlib_linalg_eigenvalues
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_cross_product.fypp 0000664 0001750 0001750 00000001070 15135654166 026701 0 ustar alastair alastair #:include "common.fypp"
#:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES
submodule (stdlib_linalg) stdlib_linalg_cross_product
implicit none
contains
#:for k1, t1 in RCI_KINDS_TYPES
pure module function cross_product_${t1[0]}$${k1}$(a, b) result(res)
${t1}$, intent(in) :: a(3), b(3)
${t1}$ :: res(3)
res(1) = a(2) * b(3) - a(3) * b(2)
res(2) = a(3) * b(1) - a(1) * b(3)
res(3) = a(1) * b(2) - a(2) * b(1)
end function cross_product_${t1[0]}$${k1}$
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_cholesky.fypp 0000664 0001750 0001750 00000013443 15135654166 025640 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
! Cholesky factorization of a matrix, based on LAPACK *POTRF functions
submodule (stdlib_linalg) stdlib_linalg_cholesky
use stdlib_linalg_constants
use stdlib_linalg_lapack, only: potrf
use stdlib_linalg_lapack_aux, only: handle_potrf_info
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
implicit none
character(*), parameter :: this = 'cholesky'
contains
#:for rk,rt,ri in RC_KINDS_TYPES
! Compute the Cholesky factorization of a symmetric / Hermitian matrix, A = L*L^T = U^T*U.
! The factorization is returned in-place, overwriting matrix A
pure module subroutine stdlib_linalg_${ri}$_cholesky_inplace(a,lower,other_zeroed,err)
!> Input matrix a[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> [optional] is the lower or upper triangular factor required? Default = lower
logical(lk), optional, intent(in) :: lower
!> [optional] should the unused half of the return matrix be zeroed out? Default: yes
logical(lk), optional, intent(in) :: other_zeroed
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Local variables
type(linalg_state_type) :: err0
integer(ilp) :: lda,n,info,j
logical(lk) :: lower_,other_zeroed_
character :: triangle
${rt}$, parameter :: zero = 0.0_${rk}$
!> Check if the lower or upper factor is required.
!> Default: use lower factor
lower_ = .true.
if (present(lower)) lower_ = lower
triangle = merge('L','U',lower_)
!> Check if the unused half of the return matrix should be zeroed out (default).
!> Otherwise it is unused and will contain garbage.
other_zeroed_ = .true.
if (present(other_zeroed)) other_zeroed_ = other_zeroed
!> Problem size
lda = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
! Check sizes
if (n<1 .or. lda<1 .or. lda Input matrix a[n,n]. On return, A is destroyed and replaced by the inverse
${rt}$, intent(inout) :: a(:,:)
!> [optional] Storage array for the diagonal pivot indices
integer(ilp), optional, intent(inout), target :: pivot(:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Local variables
type(linalg_state_type) :: err0
integer(ilp) :: lda,n,info,nb,lwork,npiv
integer(ilp), pointer :: ipiv(:)
${rt}$, allocatable :: work(:)
!> Problem sizes
lda = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
! Has a pre-allocated pivots storage array been provided?
if (present(pivot)) then
ipiv => pivot
else
allocate(ipiv(n))
endif
npiv = size(ipiv,kind=ilp)
if (lda<1 .or. n<1 .or. lda/=n .or. npiv Input matrix a[n,n].
${rt}$, intent(in) :: a(:,:)
!> Inverse matrix a[n,n].
${rt}$, intent(out) :: inva(:,:)
!> [optional] Storage array for the diagonal pivot indices
integer(ilp), optional, intent(inout), target :: pivot(:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
type(linalg_state_type) :: err0
integer(ilp) :: sa(2),sinva(2)
sa = shape(a,kind=ilp)
sinva = shape(inva,kind=ilp)
if (any(sa/=sinva)) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',sa,' inva=',sinva)
else
!> Copy data in
inva = a
!> Compute matrix inverse
call stdlib_linalg_invert_inplace_${ri}$(inva,pivot=pivot,err=err0)
end if
! Process output and return
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_invert_split_${ri}$
! Invert matrix in place
module function stdlib_linalg_inverse_${ri}$(a,err) result(inva)
!> Input matrix a[n,n]
${rt}$, intent(in) :: a(:,:)
!> Output matrix inverse
${rt}$, allocatable :: inva(:,:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Allocate with copy
allocate(inva,source=a)
!> Compute matrix inverse
call stdlib_linalg_invert_inplace_${ri}$(inva,err=err)
end function stdlib_linalg_inverse_${ri}$
! Inverse matrix operator
module function stdlib_linalg_inverse_${ri}$_operator(a) result(inva)
!> Input matrix a[n,n]
${rt}$, intent(in) :: a(:,:)
!> Result matrix
${rt}$, allocatable :: inva(:,:)
type(linalg_state_type) :: err
! Provide an error handler to return NaNs on issues
inva = stdlib_linalg_inverse_${ri}$(a,err=err)
! Return NaN on issues
if (err%error()) then
if (allocated(inva)) deallocate(inva)
allocate(inva(size(a,1,kind=ilp),size(a,2,kind=ilp)))
#:if rt.startswith('real')
inva = ieee_value(1.0_${rk}$,ieee_quiet_nan)
#:else
inva = cmplx(ieee_value(1.0_${rk}$,ieee_quiet_nan), &
ieee_value(1.0_${rk}$,ieee_quiet_nan), kind=${rk}$)
#:endif
endif
end function stdlib_linalg_inverse_${ri}$_operator
#:endfor
end submodule stdlib_linalg_inverse
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_solve.fypp 0000664 0001750 0001750 00000013065 15135654166 025147 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set RHS_SUFFIX = ["one","many"]
#:set RHS_SYMBOL = [ranksuffix(r) for r in [1,2]]
#:set RHS_EMPTY = [emptyranksuffix(r) for r in [1,2]]
#:set ALL_RHS = list(zip(RHS_SYMBOL,RHS_SUFFIX,RHS_EMPTY))
submodule (stdlib_linalg) stdlib_linalg_solve
!! Solve linear system Ax=b
use stdlib_linalg_constants
use stdlib_linalg_lapack, only: gesv
use stdlib_linalg_lapack_aux, only: handle_gesv_info
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
implicit none
character(*), parameter :: this = 'solve'
contains
#:for nd,ndsuf,nde in ALL_RHS
#:for rk,rt,ri in RC_KINDS_TYPES
! Compute the solution to a real system of linear equations A * X = B
module function stdlib_linalg_${ri}$_solve_${ndsuf}$(a,b,overwrite_a,err) result(x)
!> Input matrix a[n,n]
${rt}$, intent(inout), target :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), intent(out) :: err
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, allocatable, target :: x${nd}$
! Initialize solution shape from the rhs array
allocate(x,mold=b)
call stdlib_linalg_${ri}$_solve_lu_${ndsuf}$(a,b,x,overwrite_a=overwrite_a,err=err)
end function stdlib_linalg_${ri}$_solve_${ndsuf}$
!> Compute the solution to a real system of linear equations A * X = B (pure interface)
pure module function stdlib_linalg_${ri}$_pure_solve_${ndsuf}$(a,b) result(x)
!> Input matrix a[n,n]
${rt}$, intent(in) :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, allocatable, target :: x${nd}$
! Local variables
${rt}$, allocatable :: amat(:,:)
! Copy `a` so it can be intent(in)
allocate(amat,source=a)
! Initialize solution shape from the rhs array
allocate(x,mold=b)
call stdlib_linalg_${ri}$_solve_lu_${ndsuf}$(amat,b,x,overwrite_a=.true.)
end function stdlib_linalg_${ri}$_pure_solve_${ndsuf}$
!> Compute the solution to a real system of linear equations A * X = B (pure interface)
pure module subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$(a,b,x,pivot,overwrite_a,err)
!> Input matrix a[n,n]
${rt}$, intent(inout), target :: a(:,:)
!> Right hand side vector or array, b[n] or b[n,nrhs]
${rt}$, intent(in) :: b${nd}$
!> Result array/matrix x[n] or x[n,nrhs]
${rt}$, intent(inout), contiguous, target :: x${nd}$
!> [optional] Storage array for the diagonal pivot indices
integer(ilp), optional, intent(inout), target :: pivot(:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
! Local variables
type(linalg_state_type) :: err0
integer(ilp) :: lda,n,ldb,ldx,nrhsx,nrhs,info,npiv
integer(ilp), pointer :: ipiv(:)
logical(lk) :: copy_a
${rt}$, pointer :: xmat(:,:),amat(:,:)
! Problem sizes
lda = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
ldb = size(b,1,kind=ilp)
nrhs = size(b ,kind=ilp)/ldb
ldx = size(x,1,kind=ilp)
nrhsx = size(x ,kind=ilp)/ldx
! Has a pre-allocated pivots storage array been provided?
if (present(pivot)) then
ipiv => pivot
else
allocate(ipiv(n))
endif
npiv = size(ipiv,kind=ilp)
! Can A be overwritten? By default, do not overwrite
if (present(overwrite_a)) then
copy_a = .not.overwrite_a
else
copy_a = .true._lk
endif
if (any([lda,n,ldb]<1) .or. any([lda,ldb,ldx]/=n) .or. nrhsx/=nrhs .or. npiv/=n) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid sizes: a=',[lda,n], &
'b=',[ldb,nrhs],' x=',[ldx,nrhsx], &
'pivot=',n)
call linalg_error_handling(err0,err)
return
end if
! Initialize a matrix temporary
if (copy_a) then
allocate(amat(lda,n),source=a)
else
amat => a
endif
! Initialize solution with the rhs
x = b
xmat(1:n,1:nrhs) => x
! Solve system
call gesv(n,nrhs,amat,lda,ipiv,xmat,ldb,info)
! Process output
call handle_gesv_info(this,info,lda,n,nrhs,err0)
if (copy_a) deallocate(amat)
if (.not.present(pivot)) deallocate(ipiv)
! Process output and return
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$
#:endfor
#:endfor
end submodule stdlib_linalg_solve
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_svd.fypp 0000664 0001750 0001750 00000024371 15135654166 024615 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule(stdlib_linalg) stdlib_linalg_svd
!! Singular-Value Decomposition
use stdlib_linalg_constants
use stdlib_linalg_lapack, only: gesdd
use stdlib_linalg_lapack_aux, only: handle_gesdd_info
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR, LINALG_SUCCESS
implicit none
character(*), parameter :: this = 'svd'
!> List of internal GESDD tasks:
!> Return full matrices U, V^T to separate storage
character, parameter :: GESDD_FULL_MATRICES = 'A'
!> Return shrunk matrices U, V^T to k = min(m,n)
character, parameter :: GESDD_SHRINK_MATRICES = 'S'
!> Overwrite A storage with U (if M>=N) or VT (if M Do not return either U or VT (singular values array only)
character, parameter :: GESDD_SINGVAL_ONLY = 'N'
contains
#:for rk,rt,ri in RC_KINDS_TYPES
!> Singular values of matrix A
module function stdlib_linalg_svdvals_${ri}$(a,err) result(s)
!!### Summary
!! Compute singular values \(S \) from the singular-value decomposition of a matrix \( A = U \cdot S \cdot \V^T \).
!!
!!### Description
!!
!! This function returns the array of singular values from the singular value decomposition of a `real`
!! or `complex` matrix \( A = U \cdot S \cdot V^T \).
!!
!! param: a Input matrix of size [m,n].
!! param: err [optional] State return flag.
!!
!!### Return value
!!
!! param: s `real` array of size [min(m,n)] returning a list of singular values.
!!
!> Input matrix A[m,n]
${rt}$, intent(in), target :: a(:,:)
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Array of singular values
real(${rk}$), allocatable :: s(:)
!> Create
${rt}$, pointer :: amat(:,:)
integer(ilp) :: m,n,k
!> Create an internal pointer so the intent of A won't affect the next call
amat => a
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
!> Allocate return storage
allocate(s(k))
!> Compute singular values
call stdlib_linalg_svd_${ri}$(amat,s,overwrite_a=.false.,err=err)
end function stdlib_linalg_svdvals_${ri}$
!> SVD of matrix A = U S V^T, returning S and optionally U and V^T
module subroutine stdlib_linalg_svd_${ri}$(a,s,u,vt,overwrite_a,full_matrices,err)
!!### Summary
!! Compute singular value decomposition of a matrix \( A = U \cdot S \cdot \V^T \)
!!
!!### Description
!!
!! This function computes the singular value decomposition of a `real` or `complex` matrix \( A \),
!! and returns the array of singular values, and optionally the left matrix \( U \) containing the
!! left unitary singular vectors, and the right matrix \( V^T \), containing the right unitary
!! singular vectors.
!!
!! param: a Input matrix of size [m,n].
!! param: s Output `real` array of size [min(m,n)] returning a list of singular values.
!! param: u [optional] Output left singular matrix of size [m,m] or [m,min(m,n)] (.not.full_matrices). Contains singular vectors as columns.
!! param: vt [optional] Output right singular matrix of size [n,n] or [min(m,n),n] (.not.full_matrices). Contains singular vectors as rows.
!! param: overwrite_a [optional] Flag indicating if the input matrix can be overwritten.
!! param: full_matrices [optional] If `.true.` (default), matrices \( U \) and \( V^T \) have size [m,m], [n,n]. Otherwise, they are [m,k], [k,n] with `k=min(m,n)`.
!! param: err [optional] State return flag.
!!
!> Input matrix A[m,n]
${rt}$, intent(inout), target :: a(:,:)
!> Array of singular values
real(${rk}$), intent(out) :: s(:)
!> The columns of U contain the left singular vectors
${rt}$, optional, intent(out), target :: u(:,:)
!> The rows of V^T contain the right singular vectors
${rt}$, optional, intent(out), target :: vt(:,:)
!> [optional] Can A data be overwritten and destroyed?
logical(lk), optional, intent(in) :: overwrite_a
!> [optional] full matrices have shape(u)==[m,m], shape(vh)==[n,n] (default); otherwise
!> they are shape(u)==[m,k] and shape(vh)==[k,n] with k=min(m,n)
logical(lk), optional, intent(in) :: full_matrices
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Local variables
type(linalg_state_type) :: err0
integer(ilp) :: m,n,lda,ldu,ldvt,info,k,lwork,liwork,lrwork
integer(ilp), allocatable :: iwork(:)
logical(lk) :: overwrite_a_,full_storage,compute_uv,temp_u,temp_vt,can_overwrite_amat
character :: task
${rt}$, target :: work_dummy(1),u_dummy(1,1),vt_dummy(1,1)
${rt}$, allocatable :: work(:)
#:if rt.startswith('complex')
real(${rk}$), allocatable :: rwork(:)
#:endif
${rt}$, pointer :: amat(:,:),umat(:,:),vtmat(:,:)
!> Matrix determinant size
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
lda = m
if (.not.k>0) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid or matrix size: a=',[m,n])
call linalg_error_handling(err0,err)
return
elseif (.not.size(s,kind=ilp)>=k) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'singular value array has insufficient size:',&
' s=',shape(s,kind=ilp),', k=',k)
call linalg_error_handling(err0,err)
return
endif
! Integer storage
liwork = 8*k
allocate(iwork(liwork))
! Can A be overwritten? By default, do not overwrite
overwrite_a_ = .false.
if (present(overwrite_a)) overwrite_a_ = overwrite_a
! Initialize a matrix temporary?
if (overwrite_a_) then
amat => a
else
allocate(amat(m,n),source=a)
endif
! Check if we can overwrite amat with data that will be lost
can_overwrite_amat = (.not.overwrite_a_) .and. merge(.not.present(u),.not.present(vt),m>=n)
! Full-size matrices
if (present(full_matrices)) then
full_storage = full_matrices
else
full_storage = .true.
endif
! Decide if U, VT matrices should be computed
compute_uv = present(u) .or. present(vt)
! U, VT storage
if (present(u)) then
! User input
umat => u
temp_u = .false.
elseif ((m>=n .and. .not.overwrite_a_) .or. .not.compute_uv) then
! U not wanted, and A can be overwritten: do not allocate
umat => u_dummy
temp_u = .false.
elseif (.not.full_storage) then
! Allocate with minimum size
allocate(umat(m,k))
temp_u = .true.
else
! Allocate with regular size
allocate(umat(m,m))
temp_u = .true.
end if
if (present(vt)) then
! User input
vtmat => vt
temp_vt = .false.
elseif ((m vt_dummy
temp_vt = .false.
elseif (.not.full_storage) then
! Allocate with minimum size
allocate(vtmat(k,n))
temp_vt = .true.
else
! Allocate with regular size
allocate(vtmat(n,n))
temp_vt = .true.
end if
ldu = size(umat ,1,kind=ilp)
ldvt = size(vtmat,1,kind=ilp)
! Decide SVD task
if (.not.compute_uv) then
task = GESDD_SINGVAL_ONLY
elseif (can_overwrite_amat) then
! A is a copy: we can overwrite its storage
task = GESDD_OVERWRITE_A
elseif (.not.full_storage) then
task = GESDD_SHRINK_MATRICES
else
task = GESDD_FULL_MATRICES
end if
! Compute workspace
#:if rt.startswith('complex')
if (task==GESDD_SINGVAL_ONLY) then
lrwork = max(1,7*k)
else
lrwork = max(1,5*k*(k+1),2*k*(k+max(m,n))+k)
endif
allocate(rwork(lrwork))
#:else
lrwork = -1_ilp ! not needed
#:endif
! First call: request working storage space
lwork = -1_ilp
call gesdd(task,m,n,amat,lda,s,umat,ldu,vtmat,ldvt,&
work_dummy,lwork,#{if rt.startswith('complex')}#rwork,#{endif}#iwork,info)
call handle_gesdd_info(this,err0,info,m,n)
! Compute SVD
if (info==0) then
!> Prepare working storage
! Check if the returned working storage space is smaller than the largest value
! allowed by lwork
lwork = merge(nint(real(work_dummy(1),kind=${rk}$), kind=ilp) &
, huge(lwork) &
, real(work_dummy(1),kind=${rk}$) < real(huge(lwork),kind=${rk}$) )
allocate(work(lwork))
!> Compute SVD
call gesdd(task,m,n,amat,lda,s,umat,ldu,vtmat,ldvt,&
work,lwork,#{if rt.startswith('complex')}#rwork,#{endif}#iwork,info)
call handle_gesdd_info(this,err0,info,m,n)
endif
! Finalize storage and process output flag
if (.not.overwrite_a_) deallocate(amat)
if (temp_u) deallocate(umat)
if (temp_vt) deallocate(vtmat)
call linalg_error_handling(err0,err)
end subroutine stdlib_linalg_svd_${ri}$
#:endfor
end submodule stdlib_linalg_svd
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_matrix_functions.fypp 0000664 0001750 0001750 00000013234 15135654166 027411 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX, REAL_INIT))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX, CMPLX_INIT))
#:set RC_KINDS_TYPES = R_KINDS_TYPES + C_KINDS_TYPES
submodule (stdlib_linalg) stdlib_linalg_matrix_functions
use stdlib_constants
use stdlib_linalg_constants
use stdlib_linalg_blas, only: gemm
use stdlib_linalg_lapack, only: gesv, lacpy
use stdlib_linalg_lapack_aux, only: handle_gesv_info
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
implicit none(type, external)
character(len=*), parameter :: this = "matrix_exponential"
contains
#:for k,t,s, i in RC_KINDS_TYPES
module function stdlib_linalg_${i}$_expm_fun(A, order) result(E)
!> Input matrix A(n, n).
${t}$, intent(in) :: A(:, :)
!> [optional] Order of the Pade approximation.
integer(ilp), optional, intent(in) :: order
!> Exponential of the input matrix E = exp(A).
${t}$, allocatable :: E(:, :)
E = A
call stdlib_linalg_${i}$_expm_inplace(E, order)
end function stdlib_linalg_${i}$_expm_fun
module subroutine stdlib_linalg_${i}$_expm(A, E, order, err)
!> Input matrix A(n, n).
${t}$, intent(in) :: A(:, :)
!> Exponential of the input matrix E = exp(A).
${t}$, intent(out) :: E(:, :)
!> [optional] Order of the Pade approximation.
integer(ilp), optional, intent(in) :: order
!> [optional] State return flag.
type(linalg_state_type), optional, intent(out) :: err
type(linalg_state_type) :: err0
integer(ilp) :: lda, n, lde, ne
! Check E sizes
lda = size(A, 1, kind=ilp) ; n = size(A, 2, kind=ilp)
lde = size(E, 1, kind=ilp) ; ne = size(E, 2, kind=ilp)
if (lda<1 .or. n<1 .or. lda/=n .or. lde/=n .or. ne/=n) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR, &
'invalid matrix sizes: A must be square (lda=', lda, ', n=', n, ')', &
' E must be square (lde=', lde, ', ne=', ne, ')')
else
call lacpy("n", n, n, A, n, E, n) ! E = A
call stdlib_linalg_${i}$_expm_inplace(E, order, err0)
endif
! Process output and return
call linalg_error_handling(err0,err)
return
end subroutine stdlib_linalg_${i}$_expm
module subroutine stdlib_linalg_${i}$_expm_inplace(A, order, err)
!> Input matrix A(n, n) / Output matrix exponential.
${t}$, intent(inout) :: A(:, :)
!> [optional] Order of the Pade approximation.
integer(ilp), optional, intent(in) :: order
!> [optional] State return flag.
type(linalg_state_type), optional, intent(out) :: err
! Internal variables.
${t}$ :: A2(size(A, 1), size(A, 2)), Q(size(A, 1), size(A, 2))
${t}$ :: X(size(A, 1), size(A, 2)), X_tmp(size(A, 1), size(A, 2))
real(${k}$) :: a_norm, c
integer(ilp) :: m, n, ee, k, s, order_, i, j
logical(lk) :: p
type(linalg_state_type) :: err0
! Deal with optional args.
order_ = 10 ; if (present(order)) order_ = order
! Problem's dimension.
m = size(A, dim=1, kind=ilp) ; n = size(A, dim=2, kind=ilp)
if (m /= n) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'Invalid matrix size A=',[m, n])
else if (order_ < 0) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, 'Order of Pade approximation &
needs to be positive, order=', order_)
else
! Compute the L-infinity norm.
a_norm = mnorm(A, "inf")
! Determine scaling factor for the matrix.
ee = int(log(a_norm) / log2_${k}$, kind=ilp) + 1
s = max(0, ee+1)
! Scale the input matrix & initialize polynomial.
A2 = A/2.0_${k}$**s
call lacpy("n", n, n, A2, n, X, n) ! X = A2
! First step of the Pade approximation.
c = 0.5_${k}$
do concurrent(i=1:n, j=1:n)
A(i, j) = merge(1.0_${k}$ + c*A2(i, j), c*A2(i, j), i == j)
Q(i, j) = merge(1.0_${k}$ - c*A2(i, j), -c*A2(i, j), i == j)
enddo
! Iteratively compute the Pade approximation.
p = .true.
do k = 2, order_
c = c * (order_ - k + 1) / (k * (2*order_ - k + 1))
call lacpy("n", n, n, X, n, X_tmp, n) ! X_tmp = X
call gemm("N", "N", n, n, n, one_${s}$, A2, n, X_tmp, n, zero_${s}$, X, n)
do concurrent(i=1:n, j=1:n)
A(i, j) = A(i, j) + c*X(i, j) ! E = E + c*X
Q(i, j) = merge(Q(i, j) + c*X(i, j), Q(i, j) - c*X(i, j), p)
enddo
p = .not. p
enddo
block
integer(ilp) :: ipiv(n), info
call gesv(n, n, Q, n, ipiv, A, n, info) ! E = inv(Q) @ E
call handle_gesv_info(this, info, n, n, n, err0)
end block
! Matrix squaring.
do k = 1, s
call lacpy("n", n, n, A, n, X, n) ! X = A
call gemm("N", "N", n, n, n, one_${s}$, X, n, X, n, zero_${s}$, A, n)
enddo
endif
call linalg_error_handling(err0, err)
return
end subroutine stdlib_linalg_${i}$_expm_inplace
#:endfor
end submodule stdlib_linalg_matrix_functions
fortran-lang-stdlib-0ede301/src/linalg/stdlib_linalg_pinv.fypp 0000664 0001750 0001750 00000012043 15135654166 024766 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule(stdlib_linalg) stdlib_linalg_pseudoinverse
!! Compute the (Moore-Penrose) pseudo-inverse of a matrix.
use stdlib_linalg_constants
use stdlib_linalg_blas
use stdlib_linalg_lapack
use stdlib_linalg_state
use ieee_arithmetic, only: ieee_value, ieee_quiet_nan
implicit none
character(*), parameter :: this = 'pseudo-inverse'
contains
#:for rk,rt,ri in RC_KINDS_TYPES
! Compute the in-place pseudo-inverse of matrix a
module subroutine stdlib_linalg_pseudoinvert_${ri}$(a,pinva,rtol,err)
!> Input matrix a[m,n]
${rt}$, intent(inout) :: a(:,:)
!> Output pseudo-inverse matrix
${rt}$, intent(out) :: pinva(:,:)
!> [optional] Relative tolerance for singular value cutoff
real(${rk}$), optional, intent(in) :: rtol
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
! Local variables
real(${rk}$) :: tolerance,cutoff
real(${rk}$), allocatable :: s(:)
${rt}$, allocatable :: u(:,:),vt(:,:)
type(linalg_state_type) :: err0
integer(ilp) :: m,n,k,i,j
${rt}$, parameter :: alpha = 1.0_${rk}$, beta = 0.0_${rk}$
character, parameter :: H = #{if rt.startswith('complex')}# 'C' #{else}# 'T' #{endif}#
! Problem size
m = size(a,1,kind=ilp)
n = size(a,2,kind=ilp)
k = min(m,n)
if (m<1 .or. n<1) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',[m,n])
call linalg_error_handling(err0,err)
return
end if
if (any(shape(pinva,kind=ilp)/=[n,m])) then
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid pinv size:',shape(pinva),'should be',[n,m])
call linalg_error_handling(err0,err)
return
end if
! Singular value threshold
tolerance = max(m,n)*epsilon(0.0_${rk}$)
! User threshold: fallback to default if <=0
if (present(rtol)) then
if (rtol>0.0_${rk}$) tolerance = rtol
end if
allocate(s(k),u(m,k),vt(k,n))
call svd(a,s,u,vt,overwrite_a=.false.,full_matrices=.false.,err=err0)
if (err0%error()) then
err0 = linalg_state_type(this,LINALG_ERROR,'svd failure -',err0%message)
call linalg_error_handling(err0,err)
return
endif
!> Discard singular values
cutoff = tolerance*maxval(s)
s = merge(1.0_${rk}$/s,0.0_${rk}$,s>cutoff)
! Get pseudo-inverse: A_pinv = V * (diag(1/s) * U^H) = V * (U * diag(1/s))^H
! 1) compute (U * diag(1/s)) in-place
do concurrent (i=1:m,j=1:k)
u(i,j) = s(j)*u(i,j)
end do
! 2) commutate matmul: A_pinv = V * (U * diag(1/s))^H = ((U * diag(1/s)) * V^H)^H.
! This avoids one matrix transpose
call gemm(H, H, n, m, k, alpha, vt, k, u, m, beta, pinva, size(pinva,1,kind=ilp))
end subroutine stdlib_linalg_pseudoinvert_${ri}$
! Function interface
module function stdlib_linalg_pseudoinverse_${ri}$(a,rtol,err) result(pinva)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> [optional] Relative tolerance for singular value cutoff
real(${rk}$), optional, intent(in) :: rtol
!> [optional] state return flag. On error if not requested, the code will stop
type(linalg_state_type), optional, intent(out) :: err
!> Matrix pseudo-inverse
${rt}$ :: pinva(size(a,2,kind=ilp),size(a,1,kind=ilp))
! Use pointer to circumvent svd intent(inout) restriction
${rt}$, pointer :: ap(:,:)
ap => a
call stdlib_linalg_pseudoinvert_${ri}$(ap,pinva,rtol,err)
end function stdlib_linalg_pseudoinverse_${ri}$
! Inverse matrix operator
module function stdlib_linalg_pinv_${ri}$_operator(a) result(pinva)
!> Input matrix a[m,n]
${rt}$, intent(in), target :: a(:,:)
!> Result pseudo-inverse matrix
${rt}$ :: pinva(size(a,2,kind=ilp),size(a,1,kind=ilp))
type(linalg_state_type) :: err
! Use pointer to circumvent svd intent(inout) restriction
${rt}$, pointer :: ap(:,:)
ap => a
call stdlib_linalg_pseudoinvert_${ri}$(ap,pinva,err=err)
if (err%error()) then
#:if rt.startswith('real')
pinva = ieee_value(1.0_${rk}$,ieee_quiet_nan)
#:else
pinva = cmplx(ieee_value(1.0_${rk}$,ieee_quiet_nan), &
ieee_value(1.0_${rk}$,ieee_quiet_nan), kind=${rk}$)
#:endif
endif
end function stdlib_linalg_pinv_${ri}$_operator
#:endfor
end submodule stdlib_linalg_pseudoinverse
fortran-lang-stdlib-0ede301/src/array/ 0000775 0001750 0001750 00000000000 15135654166 020073 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/array/CMakeLists.txt 0000664 0001750 0001750 00000000277 15135654166 022641 0 ustar alastair alastair set(array_fppFiles
)
set(array_cppFiles
)
set(array_f90Files
stdlib_array.f90
)
configure_stdlib_target(${PROJECT_NAME}_array array_f90Files array_fppFiles array_cppFiles)
fortran-lang-stdlib-0ede301/src/array/stdlib_array.f90 0000664 0001750 0001750 00000003571 15135654166 023100 0 ustar alastair alastair ! SPDX-Identifier: MIT
!> Module for index manipulation and general array handling
!>
!> The specification of this module is available [here](../page/specs/stdlib_array.html).
module stdlib_array
implicit none
private
public :: trueloc, falseloc
contains
!> Version: experimental
!>
!> Return the positions of the true elements in array.
!> [Specification](../page/specs/stdlib_array.html#trueloc)
pure function trueloc(array, lbound) result(loc)
!> Mask of logicals
logical, intent(in) :: array(:)
!> Lower bound of array to index
integer, intent(in), optional :: lbound
!> Locations of true elements
integer :: loc(count(array))
call logicalloc(loc, array, .true., lbound)
end function trueloc
!> Version: experimental
!>
!> Return the positions of the false elements in array.
!> [Specification](../page/specs/stdlib_array.html#falseloc)
pure function falseloc(array, lbound) result(loc)
!> Mask of logicals
logical, intent(in) :: array(:)
!> Lower bound of array to index
integer, intent(in), optional :: lbound
!> Locations of false elements
integer :: loc(count(.not.array))
call logicalloc(loc, array, .false., lbound)
end function falseloc
!> Return the positions of the truthy elements in array
pure subroutine logicalloc(loc, array, truth, lbound)
!> Locations of truthy elements
integer, intent(out) :: loc(:)
!> Mask of logicals
logical, intent(in) :: array(:)
!> Truthy value
logical, intent(in) :: truth
!> Lower bound of array to index
integer, intent(in), optional :: lbound
integer :: i, pos, offset
offset = 0
if (present(lbound)) offset = lbound - 1
i = 0
do pos = 1, size(array)
if (array(pos).eqv.truth) then
i = i + 1
loc(i) = pos + offset
end if
end do
end subroutine logicalloc
end module stdlib_array
fortran-lang-stdlib-0ede301/src/specialfunctions/ 0000775 0001750 0001750 00000000000 15135654166 022326 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/specialfunctions/stdlib_specialfunctions.fypp 0000664 0001750 0001750 00000034047 15135654166 030150 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(2, MAXRANK + 1)
module stdlib_specialfunctions
use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
implicit none
private
interface legendre
!! version: experimental
!!
!! Legendre polynomial
pure elemental module function legendre_fp64(n,x) result(leg)
integer, intent(in) :: n
real(dp), intent(in) :: x
real(dp) :: leg
end function
end interface
public :: legendre
interface dlegendre
!! version: experimental
!!
!! First derivative Legendre polynomial
pure elemental module function dlegendre_fp64(n,x) result(dleg)
integer, intent(in) :: n
real(dp), intent(in) :: x
real(dp) :: dleg
end function
end interface
public :: dlegendre
interface gaussian
!! Version: experimental
!!
!! gaussian function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#gaussian))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gaussian_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: gaussian
interface gaussian_grad
!! Version: experimental
!!
!! gradient of the gaussian function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#gaussian_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gaussian_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: gaussian_grad
interface elu
!! Version: experimental
!!
!! exponential linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#elu))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function elu_${rk}$( x , a ) result( y )
${rt}$, intent(in) :: x
${rt}$, intent(in) :: a
${rt}$ :: y
end function
#:endfor
end interface
public :: elu
interface elu_grad
!! Version: experimental
!!
!! gradient of the exponential linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#elu_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function elu_grad_${rk}$( x , a ) result( y )
${rt}$, intent(in) :: x
${rt}$, intent(in) :: a
${rt}$ :: y
end function
#:endfor
end interface
public :: elu_grad
interface relu
!! Version: experimental
!!
!! Rectified linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#relu))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function relu_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: relu
interface relu_grad
!! Version: experimental
!!
!! Gradient rectified linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#relu_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function relu_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: relu_grad
interface leaky_relu
!! Version: experimental
!!
!! leaky Rectified linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#leaky_relu))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function leaky_relu_${rk}$( x , a ) result( y )
${rt}$, intent(in) :: x
${rt}$, intent(in) :: a
${rt}$ :: y
end function
#:endfor
end interface
public :: leaky_relu
interface leaky_relu_grad
!! Version: experimental
!!
!! Gradient of the leaky Rectified linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#leaky_relu_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function leaky_relu_grad_${rk}$( x , a ) result( y )
${rt}$, intent(in) :: x
${rt}$, intent(in) :: a
${rt}$ :: y
end function
#:endfor
end interface
public :: leaky_relu_grad
interface gelu
!! Version: experimental
!!
!! Gaussian error linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#gelu))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gelu_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: gelu
interface gelu_grad
!! Version: experimental
!!
!! Gradient of the gaussian error linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#gelu_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gelu_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: gelu_grad
interface gelu_approx
!! Version: experimental
!!
!! Approximated gaussian error linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#gelu_approx))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gelu_approx_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: gelu_approx
interface gelu_approx_grad
!! Version: experimental
!!
!! Gradient of the approximated gaussian error linear unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#gelu_approx_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gelu_approx_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: gelu_approx_grad
interface selu
!! Version: experimental
!!
!! Scaled Exponential Linear Unit
!> ([Specification](../page/specs/stdlib_specialfunctions.html#selu))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function selu_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: selu
interface selu_grad
!! Version: experimental
!!
!! Scaled Exponential Linear Unit
!> ([Specification](../page/specs/stdlib_specialfunctions.html#selu_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function selu_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: selu_grad
interface sigmoid
!! Version: experimental
!!
!! Sigmoid function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#sigmoid))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function sigmoid_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: sigmoid
interface sigmoid_grad
!! Version: experimental
!!
!! Gradient of the sigmoid function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#sigmoid_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function sigmoid_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: sigmoid_grad
interface silu
!! Version: experimental
!!
!! Sigmoid Linear Unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#silu))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function silu_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: silu
interface silu_grad
!! Version: experimental
!!
!! Gradient of the Sigmoid Linear Unit function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#silu_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function silu_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: silu_grad
interface step
!! Version: experimental
!!
!! Step function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#step))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function step_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: step
interface step_grad
!! Version: experimental
!!
!! Gradient of the step function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#step_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function step_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: step_grad
interface softmax
!! Version: experimental
!!
!! softmax function. Available for ranks 1 to 4
!> ([Specification](../page/specs/stdlib_specialfunctions.html#softmax))
#:for rk, rt in REAL_KINDS_TYPES
pure module function softmax_r1_${rk}$( x ) result( y )
${rt}$, intent(in) :: x(:)
${rt}$ :: y(size(x))
end function
#:for rank in RANKS
pure module function softmax_r${rank}$_${rk}$( x , dim ) result( y )
${rt}$, intent(in) :: x${ranksuffix(rank)}$
${rt}$ :: y${shape_from_array_size('x', rank)}$
integer, intent(in), optional :: dim
end function
#:endfor
#:endfor
end interface
public :: softmax
interface softmax_grad
!! Version: experimental
!!
!! Gradient of the softmax function. Available for ranks 1 to 4
!> ([Specification](../page/specs/stdlib_specialfunctions.html#softmax_grad))
#:for rk, rt in REAL_KINDS_TYPES
pure module function softmax_grad_r1_${rk}$( x ) result( y )
${rt}$, intent(in) :: x(:)
${rt}$ :: y(size(x))
end function
#:for rank in RANKS
pure module function softmax_grad_r${rank}$_${rk}$( x , dim ) result( y )
${rt}$, intent(in) :: x${ranksuffix(rank)}$
${rt}$ :: y${shape_from_array_size('x', rank)}$
integer, intent(in), optional :: dim
end function
#:endfor
#:endfor
end interface
public :: softmax_grad
interface logsoftmax
!! Version: experimental
!!
!! softmax function. Available for ranks 1 to 4
!> ([Specification](../page/specs/stdlib_specialfunctions.html#logsoftmax))
#:for rk, rt in REAL_KINDS_TYPES
pure module function logsoftmax_r1_${rk}$( x ) result( y )
${rt}$, intent(in) :: x(:)
${rt}$ :: y(size(x))
end function
#:for rank in RANKS
pure module function logsoftmax_r${rank}$_${rk}$( x , dim ) result( y )
${rt}$, intent(in) :: x${ranksuffix(rank)}$
${rt}$ :: y${shape_from_array_size('x', rank)}$
integer, intent(in), optional :: dim
end function
#:endfor
#:endfor
end interface
public :: logsoftmax
interface softplus
!! Version: experimental
!!
!! softplus function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#softplus))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function softplus_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: softplus
interface softplus_grad
!! Version: experimental
!!
!! Gradient of the softplus function
!> ([Specification](../page/specs/stdlib_specialfunctions.html#softplus_grad))
#:for rk, rt in REAL_KINDS_TYPES
elemental module function softplus_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: softplus_grad
interface fast_tanh
!! Version: experimental
!!
!! Fast approximation of the tanh function
#:for rk, rt in REAL_KINDS_TYPES
elemental module function fast_tanh_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: fast_tanh
interface fast_tanh_grad
!! Version: experimental
!!
!! gradient of the hyperbolic tangent function
#:for rk, rt in REAL_KINDS_TYPES
elemental module function fast_tanh_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: fast_tanh_grad
interface fast_erf
!! Version: experimental
!!
!! Fast approximation of the erf function
#:for rk, rt in REAL_KINDS_TYPES
elemental module function fast_erf_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
end function
#:endfor
end interface
public :: fast_erf
end module stdlib_specialfunctions fortran-lang-stdlib-0ede301/src/specialfunctions/stdlib_specialfunctions_activations.fypp 0000664 0001750 0001750 00000025101 15135654166 032543 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(2, MAXRANK + 1)
submodule(stdlib_specialfunctions) stdlib_specialfunctions_activations
use stdlib_intrinsics, only: sum => stdlib_sum
implicit none
#:for rk, rt in REAL_KINDS_TYPES
${rt}$, parameter :: isqrt2_${rk}$ = 1._${rk}$ / sqrt(2._${rk}$)
#:endfor
contains
!==================================================
! Gaussian
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gaussian_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = exp(-x**2)
end function
elemental module function gaussian_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = -2._${rk}$ * x * exp(-x**2)
end function
#:endfor
!==================================================
! Exponential Linear Unit
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function elu_${rk}$( x , a ) result ( y )
${rt}$, intent(in) :: x
${rt}$, intent(in) :: a
${rt}$ :: y
y = merge( x , a * (exp(x) - 1._${rk}$), x >= 0._${rk}$)
end function
elemental module function elu_grad_${rk}$( x , a ) result ( y )
${rt}$, intent(in) :: x
${rt}$, intent(in) :: a
${rt}$ :: y
y = merge( 1._${rk}$ , a * exp(x), x >= 0._${rk}$)
end function
#:endfor
!==================================================
! Rectified Linear Unit
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function relu_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = max(0._${rk}$, x)
end function
elemental module function relu_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = merge( 1._${rk}$ , 0._${rk}$, x > 0._${rk}$)
end function
#:endfor
!==================================================
! leaky Rectified Linear Unit
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function leaky_relu_${rk}$( x , a ) result( y )
${rt}$, intent(in) :: x
${rt}$, intent(in) :: a
${rt}$ :: y
y = merge( x, a * x , x >= 0._${rk}$)
end function
elemental module function leaky_relu_grad_${rk}$( x , a ) result( y )
${rt}$, intent(in) :: x
${rt}$, intent(in) :: a
${rt}$ :: y
y = merge( 1._${rk}$ , a , x >= 0._${rk}$)
end function
#:endfor
!==================================================
! GELU: Gaussian Error Linear Units function
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gelu_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = 0.5_${rk}$ * x * (1._${rk}$ + erf(x * isqrt2_${rk}$))
end function
elemental module function gelu_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = 0.5_${rk}$ * (1._${rk}$ + erf(x * isqrt2_${rk}$) )
y = y + x * isqrt2_${rk}$ * exp( - 0.5_${rk}$ * x**2 )
end function
#:endfor
#:for rk, rt in REAL_KINDS_TYPES
elemental module function gelu_approx_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = 0.5_${rk}$ * x * (1._${rk}$ + fast_erf(x * isqrt2_${rk}$))
end function
elemental module function gelu_approx_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = 0.5_${rk}$ * (1._${rk}$ + fast_erf(x * isqrt2_${rk}$) )
y = y + x * isqrt2_${rk}$ * exp( - 0.5_${rk}$ * x**2 )
end function
#:endfor
!==================================================
! Scaled Exponential Linear Unit (SELU)
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function selu_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
${rt}$, parameter :: scale = 1.0507009873554804934193349852946_${rk}$
${rt}$, parameter :: alpha = 1.6732632423543772848170429916717_${rk}$
y = merge( x , alpha * exp(x) - alpha, x > 0._${rk}$)
y = scale * y
end function
elemental module function selu_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
${rt}$, parameter :: scale = 1.0507009873554804934193349852946_${rk}$
${rt}$, parameter :: alpha = 1.6732632423543772848170429916717_${rk}$
y = merge( scale , scale * alpha * exp(x), x > 0._${rk}$)
end function
#:endfor
!==================================================
! Sigmoid
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function sigmoid_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = 1._${rk}$ / (1._${rk}$ + exp(-x))
end function
elemental module function sigmoid_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = exp(x) / (1._${rk}$ + exp(x))**2
end function
#:endfor
!==================================================
! SiLU: Sigmoid Linear Unit
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function silu_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = x / (1._${rk}$ + exp(-x))
end function
elemental module function silu_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = (1._${rk}$ + exp(x))**2
y = exp(x) * ( x + y ) / y
end function
#:endfor
!==================================================
! Step
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function step_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = merge( 1._${rk}$ , 0._${rk}$, x > 0._${rk}$)
end function
elemental module function step_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = 0._${rk}$
end function
#:endfor
!==================================================
! softmax
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
pure module function softmax_r1_${rk}$( x ) result( y )
${rt}$, intent(in) :: x(:)
${rt}$ :: y(size(x))
y = exp(x - maxval(x))
y = y / sum(y)
end function
#:for rank in RANKS
pure module function softmax_r${rank}$_${rk}$( x , dim ) result( y )
${rt}$, intent(in) :: x${ranksuffix(rank)}$
${rt}$ :: y${shape_from_array_size('x', rank)}$
integer, intent(in), optional :: dim
integer :: dim_, j
dim_ = 1; if(present(dim)) dim_ = dim
if(dim_<${rank}$)then
do j = 1, size(x,dim=${rank}$)
#:if rank == 2
y${select_subarray(rank, [(rank, 'j')])}$ = softmax( x${select_subarray(rank, [(rank, 'j')])}$ )
#:else
y${select_subarray(rank, [(rank, 'j')])}$ = softmax( x${select_subarray(rank, [(rank, 'j')])}$, dim=dim_ )
#:endif
end do
else
do j = 1, size(x,dim=1)
#:if rank == 2
y${select_subarray(rank, [(1, 'j')])}$ = softmax( x${select_subarray(rank, [(1, 'j')])}$ )
#:else
y${select_subarray(rank, [(1, 'j')])}$ = softmax( x${select_subarray(rank, [(1, 'j')])}$, dim=${rank-1}$ )
#:endif
end do
end if
end function
#:endfor
pure module function softmax_grad_r1_${rk}$( x ) result( y )
${rt}$, intent(in) :: x(:)
${rt}$ :: y(size(x))
y = softmax(x)
y = y * (1._${rk}$ - y)
end function
#:for rank in RANKS
pure module function softmax_grad_r${rank}$_${rk}$( x , dim ) result( y )
${rt}$, intent(in) :: x${ranksuffix(rank)}$
${rt}$ :: y${shape_from_array_size('x', rank)}$
integer, intent(in), optional :: dim
integer :: dim_
dim_ = 1; if(present(dim)) dim_ = dim
y = softmax(x,dim_)
y = y * (1._${rk}$ - y)
end function
#:endfor
#:endfor
!==================================================
! logsoftmax
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
pure module function logsoftmax_r1_${rk}$( x ) result( y )
${rt}$, intent(in) :: x(:)
${rt}$ :: y(size(x))
y = x - maxval(x)
y = y - log( sum(exp(y)) )
end function
#:for rank in RANKS
pure module function logsoftmax_r${rank}$_${rk}$( x , dim ) result( y )
${rt}$, intent(in) :: x${ranksuffix(rank)}$
${rt}$ :: y${shape_from_array_size('x', rank)}$
integer, intent(in), optional :: dim
integer :: dim_, j
dim_ = 1; if(present(dim)) dim_ = dim
if(dim_<${rank}$)then
do j = 1, size(x,dim=${rank}$)
#:if rank == 2
y${select_subarray(rank, [(rank, 'j')])}$ = logsoftmax( x${select_subarray(rank, [(rank, 'j')])}$ )
#:else
y${select_subarray(rank, [(rank, 'j')])}$ = logsoftmax( x${select_subarray(rank, [(rank, 'j')])}$, dim=dim_ )
#:endif
end do
else
do j = 1, size(x,dim=1)
#:if rank == 2
y${select_subarray(rank, [(1, 'j')])}$ = logsoftmax( x${select_subarray(rank, [(1, 'j')])}$ )
#:else
y${select_subarray(rank, [(1, 'j')])}$ = logsoftmax( x${select_subarray(rank, [(1, 'j')])}$, dim=${rank-1}$ )
#:endif
end do
end if
end function
#:endfor
#:endfor
!==================================================
! softplus
!==================================================
#:for rk, rt in REAL_KINDS_TYPES
elemental module function softplus_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = log(exp(x) + 1._${rk}$)
end function
elemental module function softplus_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = exp(x) / (exp(x) + 1._${rk}$)
end function
#:endfor
!==================================================
! Fast intrinsics for accelerated activations
!==================================================
! Source: https://fortran-lang.discourse.group/t/fastgpt-faster-than-pytorch-in-300-lines-of-fortran/5385/31
#:for rk, rt in REAL_KINDS_TYPES
elemental module function fast_tanh_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
${rt}$ :: x2, a, b
x2 = x*x
a = x * (135135.0_${rk}$ + x2 * (17325.0_${rk}$ + x2 * (378.0_${rk}$ + x2)))
b = 135135.0_${rk}$ + x2 * (62370.0_${rk}$ + x2 * (3150.0_${rk}$ + x2 * 28.0_${rk}$))
y = merge( a / b , sign(1._${rk}$,x) , x2 <= 25._${rk}$ )
end function
elemental module function fast_tanh_grad_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
y = 1._${rk}$ - fast_tanh(x)**2
end function
elemental module function fast_erf_${rk}$( x ) result( y )
${rt}$, intent(in) :: x
${rt}$ :: y
${rt}$ :: abs_x
abs_x = abs(x)
y = 1._${rk}$ - 1._${rk}$ / (1._${rk}$+ 0.278393_${rk}$*abs_x + 0.230389_${rk}$*abs_x**2 + 0.000972_${rk}$*abs_x**3 + 0.078108_${rk}$*abs_x**4)**4
y = y * sign(1.0_${rk}$,x)
end function
#:endfor
end submodule fortran-lang-stdlib-0ede301/src/specialfunctions/stdlib_specialfunctions_gamma.fypp 0000664 0001750 0001750 00000105123 15135654166 031304 0 ustar alastair alastair #:include "common.fypp"
#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set IDX_CMPLX_KINDS_TYPES = [(i, CMPLX_KINDS[i], CMPLX_TYPES[i], CMPLX_INIT[i]) for i in range(len(CMPLX_KINDS))]
#:set IDX_REAL_KINDS_TYPES = [(i, REAL_KINDS[i], REAL_TYPES[i], REAL_INIT[i]) for i in range(len(REAL_KINDS))]
module stdlib_specialfunctions_gamma
use ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_kinds, only : sp, dp, xdp, qp, int8, int16, int32, int64
use stdlib_error, only : error_stop
implicit none
private
integer(int8), parameter :: max_fact_int8 = 6_int8
integer(int16), parameter :: max_fact_int16 = 8_int16
integer(int32), parameter :: max_fact_int32 = 13_int32
integer(int64), parameter :: max_fact_int64 = 21_int64
#:for k1, t1 in REAL_KINDS_TYPES
${t1}$, parameter :: tol_${k1}$ = epsilon(1.0_${k1}$)
#:endfor
public :: gamma, log_gamma, log_factorial
public :: lower_incomplete_gamma, log_lower_incomplete_gamma
public :: upper_incomplete_gamma, log_upper_incomplete_gamma
public :: regularized_gamma_p, regularized_gamma_q
interface gamma
!! Gamma function for integer and complex numbers
!!
#:for k1, t1 in CI_KINDS_TYPES[:-1]
module procedure gamma_${t1[0]}$${k1}$
#:endfor
end interface gamma
interface log_gamma
!! Logarithm of gamma function
!!
#:for k1, t1 in CI_KINDS_TYPES[:-1]
module procedure l_gamma_${t1[0]}$${k1}$
#:endfor
end interface log_gamma
interface log_factorial
!! Logarithm of factorial n!, integer variable
!!
#:for k1, t1 in INT_KINDS_TYPES
module procedure l_factorial_${t1[0]}$${k1}$
#:endfor
end interface log_factorial
interface lower_incomplete_gamma
!! Lower incomplete gamma function
!!
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
module procedure ingamma_low_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
module procedure ingamma_low_${t1[0]}$${k1}$
#:endfor
end interface lower_incomplete_gamma
interface log_lower_incomplete_gamma
!! Logarithm of lower incomplete gamma function
!!
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
module procedure l_ingamma_low_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
module procedure l_ingamma_low_${t1[0]}$${k1}$
#:endfor
end interface log_lower_incomplete_gamma
interface upper_incomplete_gamma
!! Upper incomplete gamma function
!!
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
module procedure ingamma_up_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
module procedure ingamma_up_${t1[0]}$${k1}$
#:endfor
end interface upper_incomplete_gamma
interface log_upper_incomplete_gamma
!! Logarithm of upper incomplete gamma function
!!
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
module procedure l_ingamma_up_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
module procedure l_ingamma_up_${t1[0]}$${k1}$
#:endfor
end interface log_upper_incomplete_gamma
interface regularized_gamma_p
!! Regularized (normalized) lower incomplete gamma function, P
!!
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
module procedure regamma_p_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
module procedure regamma_p_${t1[0]}$${k1}$
#:endfor
end interface regularized_gamma_p
interface regularized_gamma_q
!! Regularized (normalized) upper incomplete gamma function, Q
!!
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
module procedure regamma_q_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
module procedure regamma_q_${t1[0]}$${k1}$
#:endfor
end interface regularized_gamma_q
interface gpx
! Incomplete gamma G function.
! Internal use only
!
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
module procedure gpx_${t1[0]}$${k1}$ !for real p and x
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
module procedure gpx_${t1[0]}$${k1}$${k2}$ !for integer p and real x
#:endfor
#:endfor
end interface gpx
interface l_gamma
! Logarithm of gamma with integer argument for designated output kind.
! Internal use only
!
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
module procedure l_gamma_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
end interface l_gamma
contains
#:for k1, t1 in INT_KINDS_TYPES
impure elemental function gamma_${t1[0]}$${k1}$(z) result(res)
${t1}$, intent(in) :: z
${t1}$ :: res, i
${t1}$, parameter :: zero = 0_${k1}$, one = 1_${k1}$
if(z <= zero) call error_stop("Error(gamma): Gamma function argument" &
//" must be positive integer.")
if(z > max_fact_${k1}$) call error_stop("Error(gamma): Gamma function" &
//" integer argument is greater than the upper limit from which an"&
//" integer overflow will be generated. Suggest switch to high " &
//" precision or convert to real data type")
res = one
do i = one, z - one
res = res * i
end do
end function gamma_${t1[0]}$${k1}$
#:endfor
#! Because the KIND lists are sorted by increasing accuracy,
#! gamma will use the next available more accurate KIND for the
#! internal more accurate solver.
#:for i, k1, t1, i1 in IDX_CMPLX_KINDS_TYPES[:-1]
#:set k2 = CMPLX_KINDS[i + 1] if k1 == "sp" else CMPLX_KINDS[-1]
#:set t2 = "real({})".format(k2)
impure elemental function gamma_${t1[0]}$${k1}$(z) result(res)
${t1}$, intent(in) :: z
${t1}$ :: res
integer :: i
real(${k1}$), parameter :: zero_k1 = 0.0_${k1}$
${t2}$, parameter :: half = 0.5_${k2}$, &
one = 1.0_${k2}$, pi = acos(- one), sqpi = sqrt(pi)
complex(${k2}$) :: y, x, sum
#:if k1 == "sp"
#! for single precision input, using double precision for calculation
integer, parameter :: n = 10
${t2}$, parameter :: r = 10.900511_${k2}$
${t2}$, parameter :: d(0 : n) = [2.48574089138753566e-5_${k2}$, &
1.05142378581721974_${k2}$, &
-3.45687097222016235_${k2}$, &
4.51227709466894824_${k2}$, &
-2.98285225323576656_${k2}$, &
1.05639711577126713_${k2}$, &
-1.95428773191645870e-1_${k2}$, &
1.70970543404441224e-2_${k2}$, &
-5.71926117404305781e-4_${k2}$, &
4.63399473359905637e-6_${k2}$, &
-2.71994908488607704e-9_${k2}$]
! parameters from above referenced source.
#:else
#! for double or extended precision input, using quadruple precision for calculation
integer, parameter :: n = 24
${t2}$, parameter :: r = 25.617904_${k2}$
${t2}$, parameter :: d(0 : n)= &
[1.0087261714899910504854136977047144166e-11_${k2}$, &
1.6339627701280724777912729825256860624_${k2}$, &
-1.4205787702221583745972794018472259342e+1_${k2}$, &
5.6689501646428786119793943350900908698e+1_${k2}$, &
-1.3766376824252176069406853670529834070e+2_${k2}$, &
2.2739972766608392140035874845640820558e+2_${k2}$, &
-2.7058382145757164380300118233258834430e+2_${k2}$, &
2.39614374587263042692333711131832094166e+2_${k2}$, &
-1.6090450559507517723393498276315290189e+2_${k2}$, &
8.27378183187161305711485619113605553100e+1_${k2}$, &
-3.2678977082742592701862249152153110206e+1_${k2}$, &
9.89018079175824824537131521501652931756_${k2}$, &
-2.2762136356329318377213053650799013041_${k2}$, &
3.93265017303573867227590563182750070164e-1_${k2}$, &
-5.0051054352146209116457193223422284239e-2_${k2}$, &
4.57142601898244576789629257292603538238e-3_${k2}$, &
-2.8922592124650765614787233510990416584e-4_${k2}$, &
1.20833375377219592849746118012697473202e-5_${k2}$, &
-3.1220812187551248389268359432609135033e-7_${k2}$, &
4.55117045361638520378367871355819524460e-9_${k2}$, &
-3.2757632817493581828033170342853173968e-11_${k2}$, &
9.49784279240135747819870224486376897253e-14_${k2}$, &
-7.9480594917454410117072562195702526836e-17_${k2}$, &
1.04692819439870077791406760109955648941e-20_${k2}$, &
-5.8990280044857540075384586350723191533e-26_${k2}$]
! parameters from above referenced source.
#:endif
if(abs(z % im) < tol_${k1}$) then
res = cmplx(gamma(z % re), kind = ${k1}$)
return
end if
if(z % re < zero_k1) then
x = cmplx(abs(z % re), - z % im, kind = ${k1}$)
y = x - one
else
y = z - one
end if
sum = cmplx(d(0), kind = ${k2}$)
do i = 1, n
sum = sum + d(i) / (y + i)
end do
y = exp((y + half) * log(y + half + r) - y) * sum
y = y * 2 / sqpi !Re(z) > 0 return
if(z % re < zero_k1 ) then
y = - pi / (sin(pi * x) * x * y) !Re(z) < 0 return
end if
res = y
end function gamma_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
impure elemental function l_gamma_${t1[0]}$${k1}$(z) result(res)
!
! Logarithm of gamma function for integer input
!
${t1}$, intent(in) :: z
real(dp) :: res
${t1}$ :: i
${t1}$, parameter :: zero = 0_${k1}$, one = 1_${k1}$, two = 2_${k1}$
if(z <= zero) call error_stop("Error(log_gamma): Gamma function" &
//" argument must be positive integer.")
select case(z)
case (one)
res = 0.0
case (two :)
res = 0.0
do i = one, z - one
res = res + log(real(i,dp))
end do
end select
end function l_gamma_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
impure elemental function l_gamma_${t1[0]}$${k1}$${k2}$(z, x) result(res)
!
! Logarithm of gamma function for integer input with defined precision output
!
${t1}$, intent(in) :: z
${t2}$, intent(in) :: x
${t2}$ :: res
${t1}$ :: i
${t1}$, parameter :: zero = 0_${k1}$, one = 1_${k1}$, two = 2_${k1}$
${t2}$, parameter :: zero_k2 = 0.0_${k2}$
if(z <= zero) call error_stop("Error(log_gamma): Gamma function" &
//" argument must be positive integer.")
select case(z)
case (one)
res = zero_k2
case (two :)
res = zero_k2
do i = one, z - one
res = res + log(real(i, ${k2}$))
end do
end select
end function l_gamma_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#! Because the KIND lists are sorted by increasing accuracy,
#! gamma will use the next available more accurate KIND for the
#! internal more accurate solver.
#:for i, k1, t1, i1 in IDX_CMPLX_KINDS_TYPES[:-1]
#:set k2 = CMPLX_KINDS[i + 1] if k1 == "sp" else CMPLX_KINDS[-1]
#:set t2 = "real({})".format(k2)
impure elemental function l_gamma_${t1[0]}$${k1}$(z) result (res)
!
! log_gamma function for any complex number, excluding negative whole number
! "Computation of special functions", Shanjie Zhang & Jianmin Jin, 1996, p.48
! "Computing the principal branch of log-gamma", D.E.G. Hare,
! J. of Algorithms, 25(2), 1997 p. 221–236
!
! Fortran 90 program by Jim-215-Fisher
!
${t1}$, intent(in) :: z
${t1}$ :: res, z1, z2
real(${k1}$) :: d
integer :: m, i
complex(${k2}$) :: zr, zr2, sum, s
real(${k1}$), parameter :: z_limit = 10.0_${k1}$, zero_k1 = 0.0_${k1}$
integer, parameter :: n = 20
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$, &
pi = acos(-one), ln2pi = log(2 * pi)
${t2}$, parameter :: a(n) = [ &
.8333333333333333333333333333333333333333E-1_${k2}$,&
-.2777777777777777777777777777777777777778E-2_${k2}$,&
.7936507936507936507936507936507936507937E-3_${k2}$,&
-.5952380952380952380952380952380952380952E-3_${k2}$,&
.8417508417508417508417508417508417508418E-3_${k2}$,&
-.1917526917526917526917526917526917526918E-2_${k2}$,&
.6410256410256410256410256410256410256410E-2_${k2}$,&
-.2955065359477124183006535947712418300654E-1_${k2}$,&
.1796443723688305731649384900158893966944E+0_${k2}$,&
-.1392432216905901116427432216905901116427E+1_${k2}$,&
.1340286404416839199447895100069013112491E+2_${k2}$,&
-.1568482846260020173063651324520889738281E+3_${k2}$,&
.2193103333333333333333333333333333333333E+4_${k2}$,&
-.3610877125372498935717326521924223073648E+5_${k2}$,&
.6914722688513130671083952507756734675533E+6_${k2}$,&
-.1523822153940741619228336495888678051866E+8_${k2}$,&
.3829007513914141414141414141414141414141E+9_${k2}$,&
-.1088226603578439108901514916552510537473E+11_${k2}$,&
.3473202837650022522522522522522522522523E+12_${k2}$,&
-.1236960214226927445425171034927132488108E+14_${k2}$]
! parameters from above reference
z2 = z
if(z % re < zero_k1) then
z2 = cmplx(abs(z % re), - z % im, kind = ${k1}$) + 1
end if
d = hypot(z2 % re, z2 % im)
z1 = z2
m = 0
if(d <= z_limit) then !for small |z|
m = ceiling(z_limit - d)
z1 = z2 + m
end if
zr = one / z1
zr2 = zr * zr
sum = (((a(20) * zr2 + a(19)) * zr2 + a(18)) * zr2 + a(17)) * zr2
sum = (((sum + a(16)) * zr2 + a(15)) * zr2 + a(14)) * zr2
sum = (((sum + a(13)) * zr2 + a(12)) * zr2 + a(11)) * zr2
sum = (((sum + a(10)) * zr2 + a(9)) * zr2 + a(8)) * zr2
sum = (((sum + a(7)) * zr2 + a(6)) * zr2 + a(5)) * zr2
sum = (((sum + a(4)) * zr2 + a(3)) * zr2 + a(2)) * zr2
sum = (sum + a(1)) * zr + ln2pi / 2 - z1 + (z1 - 0.5_${k2}$) * log(z1)
if(m /= 0) then
s = cmplx(zero, zero, kind = ${k2}$)
do i = 1, m
s = s + log(cmplx(z1, kind = ${k2}$) - i)
end do
sum = sum - s
end if
if(z % re < zero_k1) then
sum = log(pi) - log(sin(pi * z)) - sum
m = ceiling((2 * z % re - 3) / 4)
sum % im = sum % im + 2 * pi * m * sign(1.0_${k1}$, z % im)
end if
res = cmplx(sum, kind = ${k1}$)
end function l_gamma_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set k2, t2 = REAL_KINDS[-2], REAL_TYPES[-2]
impure elemental function l_factorial_${t1[0]}$${k1}$(n) result(res)
!
! Log(n!)
!
${t1}$, intent(in) :: n
${t2}$ :: res
${t1}$, parameter :: zero = 0_${k1}$, one = 1_${k1}$, two = 2_${k1}$
${t2}$, parameter :: zero_${k2}$ = 0.0_${k2}$, one_${k2}$ = 1.0_${k2}$
if(n < zero) call error_stop("Error(l_factorial): Logarithm of" &
//" factorial function argument must be non-negative")
select case(n)
case (zero)
res = zero_${k2}$
case (one)
res = zero_${k2}$
case (two : )
res = l_gamma(n + 1, one_${k2}$)
end select
end function l_factorial_${t1[0]}$${k1}$
#:endfor
#! Because the KIND lists are sorted by increasing accuracy,
#! gamma will use the next available more accurate KIND for the
#! internal more accurate solver.
#:for i, k1, t1, i1 in IDX_REAL_KINDS_TYPES[:-1]
#:set k2 = REAL_KINDS[i + 1] if k1 == "sp" else REAL_KINDS[-1]
#:set t2 = REAL_TYPES[i + 1]
impure elemental function gpx_${t1[0]}$${k1}$(p, x) result(res)
!
! Approximation of incomplete gamma G function with real argument p.
!
! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and
! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM
! Transactions on Mathematical Software, March 2020.
!
! Fortran 90 program by Jim-215-Fisher
!
${t1}$, intent(in) :: p, x
integer :: n
${t2}$ :: res, p_lim, a, b, g, c, d, y
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$
${t2}$, parameter :: dm = tiny(1.0_${k2}$) * 10 ** 6
${t1}$, parameter :: zero_k1 = 0.0_${k1}$
if(p <= zero_k1) call error_stop("Error(gpx): Incomplete gamma" &
//" function must have a positive parameter p")
if(x < -9.0_${k1}$) then
p_lim = 5.0_${k1}$ * (sqrt(abs(x)) - 1.0_${k1}$)
elseif(x >= -9.0_${k1}$ .and. x <= zero_k1) then
p_lim = zero_k1
else
p_lim = x
endif
if(x < zero_k1 .and. p < p_lim .and. abs(anint(p) - p) > tol_${k1}$) &
call error_stop("Error(gpx): Incomplete gamma function with " &
//"negative x must come with a whole number p not too small")
if(x < zero_k1) call error_stop("Error(gpx): Incomplete gamma" &
// " function with negative x must have an integer parameter p")
if(p >= p_lim) then !use modified Lentz method of continued fraction
!for eq. (15) in the above reference.
a = one
b = p
g = a / b
c = a / dm
d = one / b
n = 2
do
if(mod(n, 2) == 0) then
a = (one - p - n / 2) * x
else
a = (n / 2) * x
end if
b = p - one + n
d = d * a + b
if(d == zero) d = dm
c = b + a / c
if(c == zero) c = dm
d = one / d
y = c * d
g = g * y
n = n + 1
if(abs(y - one) < tol_${k2}$) exit
end do
else if(x >= zero_k1) then !use modified Lentz method of continued
!fraction for eq. (16) in the reference.
a = one
b = x + one - p
g = a / b
c = a / dm
d = one / b
n = 2
do
a = (n - 1) * (1 + p - n)
b = b + 2
d = d * a + b
if(d == zero) d = dm
c = b + a / c
if(c == zero) c = dm
d = one / d
y = c * d
g = g * y
n = n + 1
if(abs(y - one) < tol_${k2}$) exit
end do
else
g = ieee_value(1._${k1}$, ieee_quiet_nan)
end if
res = g
end function gpx_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
impure elemental function gpx_${t1[0]}$${k1}$${k2}$(p, x) result(res)
!
! Approximation of incomplete gamma G function with integer argument p.
!
! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and
! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM
! Transactions on Mathematical Software, March 2020.
!
${t1}$, intent(in) :: p
${t2}$, intent(in) :: x
${t2}$ :: res, p_lim, a, b, g, c, d, y
integer :: n
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$
${t2}$, parameter :: dm = tiny(1.0_${k2}$) * 10 ** 6
${t1}$, parameter :: zero_k1 = 0_${k1}$, two = 2_${k1}$
if(p <= zero_k1) call error_stop("Error(gpx): Incomplete gamma " &
//"function must have a positive parameter p")
if(x < -9.0_${k2}$) then
p_lim = 5.0_${k2}$ * (sqrt(abs(x)) - 1.0_${k2}$)
else if(x >= -9.0_${k2}$ .and. x <= zero) then
p_lim = zero
else
p_lim = x
end if
if(real(p, ${k2}$) >= p_lim) then
a = one
b = p
g = a / b
c = a / dm
d = one / b
n = 2
do
if(mod(n, 2) == 0) then
a = (one - p - n / 2) * x
else
a = (n / 2) * x
end if
b = p - 1 + n
d = d * a + b
if(d == zero) d = dm
c = b + a / c
if(c == zero) c = dm
d = one / d
y = c * d
g = g * y
n = n + 1
if(abs(y - one) < tol_${k2}$) exit
end do
else if(x >= zero) then
a = one
b = x + 1 - p
g = a / b
c = a / dm
d = one / b
n = 2
do
a = -(n - 1) * (n - 1 - p)
b = b + 2
d = d * a + b
if(d == zero) d = dm
c = b + a / c
if(c == zero) c = dm
d = one / d
y = c * d
g = g * y
n = n + 1
if(abs(y - one) < tol_${k2}$) exit
end do
else
a = -x
c = one / a
d = p - 1
b = c * (a - d)
n = 1
do
c = d * (d - one) / (a * a)
d = d - 2
y = c * ( a - d)
b = b + y
n = n + 1
if(int(n, ${k1}$) > (p - two) / two .or. y < b * tol_${k2}$) exit
end do
if(y >= b * tol_${k2}$ .and. mod(p, two) /= zero_k1) &
b = b + d * c / a
g = ((-1) ** p * exp(-a + l_gamma(p, one) - (p - 1) * log(a)) &
+ b ) / a
end if
res = g
end function gpx_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
impure elemental function ingamma_low_${t1[0]}$${k1}$(p, x) result(res)
!
! Approximation of lower incomplete gamma function with real p.
!
${t1}$, intent(in) :: p, x
${t1}$ :: res, s1, y
${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
if(x == zero) then
res = zero
else if(x > p) then
s1 = log_gamma(p)
y = one - exp(-x + p * log(x) - s1) * gpx(p, x)
res = exp(s1 + log(y))
else if(x <= p .and. x > zero) then
s1 = -x + p * log(x)
res = gpx(p, x) * exp(s1)
else
call error_stop("Error(Logarithm of upper incomplete gamma " &
//"function): negative x must be with integer p")
end if
end function ingamma_low_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
impure elemental function ingamma_low_${t1[0]}$${k1}$${k2}$(p, x) &
result(res)
!
! Approximation of lower incomplete gamma function with integer p.
!
${t1}$, intent(in) :: p
${t2}$, intent(in) :: x
${t2}$ :: res, s1, y
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$
if(x == zero) then
res = zero
else if(x > real(p, ${k2}$)) then
s1 = l_gamma(p, one)
y = one - exp(-x + p * log(x) - s1) * gpx(p, x)
res = exp(s1 + log(y))
else if(x <= real(p, ${k2}$) .and. x > zero) then
s1 = -x + p * log(x)
res = gpx(p, x) * exp(s1)
else
s1 = -x + p * log(abs(x))
res = gpx(p, x) * exp(s1)
res = (-1) ** p * res
end if
end function ingamma_low_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
impure elemental function l_ingamma_low_${t1[0]}$${k1}$(p, x) result(res)
${t1}$, intent(in) :: p, x
${t1}$ :: res, s1, y
${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
if(x == zero) then
res = zero
else if(x > p) then
s1 = log_gamma(p)
y = one - exp(-x + p * log(x) - s1) * gpx(p, x)
res = s1 + log(y)
else if(x <= p .and. x > zero) then
s1 = -x + p * log(abs(x))
res = log(abs(gpx(p, x))) + s1
else
call error_stop("Error(Logarithm of upper incomplete gamma " &
//"function): negative x must be with integer p")
end if
end function l_ingamma_low_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
impure elemental function l_ingamma_low_${t1[0]}$${k1}$${k2}$(p, x) &
result(res)
${t1}$, intent(in) :: p
${t2}$, intent(in) :: x
${t2}$ :: res, s1, y
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$
if(x == zero) then
res = zero
else if(x > real(p, ${k2}$)) then
s1 = l_gamma(p, one)
y = one - exp(-x + p * log(x) - s1) * gpx(p, x)
res = s1 + log(y)
else if(x <= real(p, ${k2}$)) then
s1 = -x + p * log(abs(x))
res = log(abs(gpx(p, x))) + s1
end if
end function l_ingamma_low_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
impure elemental function ingamma_up_${t1[0]}$${k1}$(p, x) result(res)
!
! Approximation of upper incomplete gamma function with real p.
!
${t1}$, intent(in) :: p, x
${t1}$ :: res, s1, y
${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
if(x == zero) then
res = gamma(p)
else if(x > p) then
s1 = -x + p * log(x)
res = gpx(p, x) * exp(s1)
else if(x <= p .and. x > zero) then
y = log_gamma(p)
s1 = -x + p * log(x) - y
res = (one - gpx(p, x) * exp(s1)) * exp(y)
else
call error_stop("Error(Logarithm of upper incomplete gamma " &
//"function): negative x must be with integer p")
end if
end function ingamma_up_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
impure elemental function ingamma_up_${t1[0]}$${k1}$${k2}$(p, x) &
result(res)
!
! Approximation of upper incomplete gamma function with integer p.
!
${t1}$, intent(in) :: p
${t2}$, intent(in) :: x
${t2}$ :: res, s1, y
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$
if(x == zero) then
res = gamma(real(p, ${k2}$))
else if(x > real(p, ${k2}$)) then
s1 = -x + p * log(x)
res = gpx(p, x) * exp(s1)
else if(x <= real(p, ${k2}$) .and. x > zero) then
y = l_gamma(p, one)
s1 = -x + p * log(x) - y
res = gpx(p, x) * exp(s1)
res = (one - res) * exp(y)
else
y = l_gamma(p, one)
s1 = -x + p * log(abs(x)) - y
res = gpx(p, x) * exp(s1)
res = (one - (-1) ** p * res) * exp(y)
end if
end function ingamma_up_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
impure elemental function l_ingamma_up_${t1[0]}$${k1}$(p, x) result(res)
${t1}$, intent(in) :: p, x
${t1}$ :: res, s1, y
${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
if(x == zero) then
res = log_gamma(p)
else if(x > p) then
s1 = -x + p * log(x)
res = log(gpx(p, x)) + s1
else if(x <= p .and. x > zero) then
y= log_gamma(p)
s1 = -x + p * log(x) - y
res = gpx(p, x) * exp(s1)
res = log(one - res) + y
else
call error_stop("Error(Logarithm of upper incomplete gamma " &
//"function): negative x must be with integer p")
end if
end function l_ingamma_up_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
impure elemental function l_ingamma_up_${t1[0]}$${k1}$${k2}$(p, x) &
result(res)
${t1}$, intent(in) :: p
${t2}$, intent(in) :: x
${t2}$ :: res, s1, y
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$
if(x == zero) then
res = l_gamma(p, one)
else if(x > real(p, ${k2}$)) then
s1 = -x + p * log(x)
res = log(gpx(p, x)) + s1
else if(x <= real(p, ${k2}$) .and. x > zero) then
y = l_gamma(p, one)
s1 = -x + p * log(x) - y
res = gpx(p, x) * exp(s1)
res = log(one - res) + y
else
y = l_gamma(p, one)
s1 = -x + p * log(abs(x)) + log(gpx(p, x))
res = (-1) ** p * exp(s1)
res = log(abs(exp(y) - res))
end if
end function l_ingamma_up_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
impure elemental function regamma_p_${t1[0]}$${k1}$(p, x) result(res)
!
! Approximation of regularized incomplete gamma function P(p,x) for real p
!
${t1}$, intent(in) :: p, x
${t1}$ :: res, s1
${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
if(x < zero) call error_stop("Error(regamma_p): Regularized gamma_p" &
//" function is not defined at x < 0")
if(x == zero) then
res = zero
else if(x > p) then
s1 = -x + p * log(x) - log_gamma(p)
res = one - exp(s1 + log(gpx(p,x)))
else if(x <= p) then
s1 = -x + p * log(abs(x)) - log_gamma(p)
res = exp(log(gpx(p, x)) + s1)
end if
end function regamma_p_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
impure elemental function regamma_p_${t1[0]}$${k1}$${k2}$(p, x) result(res)
!
! Approximation of regularized incomplete gamma function P(p,x) for integer p
!
${t1}$, intent(in) :: p
${t2}$, intent(in) :: x
${t2}$ :: res, s1
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$
if(x < zero) call error_stop("Error(regamma_p): Regularized gamma_p" &
//" function is not defined at x < 0")
if(x == zero) then
res = zero
else if(x > real(p, ${k2}$)) then
s1 = -x + p * log(x) - l_gamma(p, one)
res = one - exp(s1 + log(gpx(p,x)))
else if(x <= real(p, ${k2}$)) then
s1 = -x + p * log(abs(x)) - l_gamma(p, one)
res = exp(log(gpx(p, x)) + s1)
end if
end function regamma_p_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES[:-1]
impure elemental function regamma_q_${t1[0]}$${k1}$(p, x) result(res)
!
! Approximation of regularized incomplete gamma function Q(p,x) for real p
!
${t1}$, intent(in) :: p, x
${t1}$ :: res, s1
${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
if(x < zero) call error_stop("Error(regamma_p): Regularized gamma_q" &
//" function is not defined at x < 0")
if(x == zero) then
res = one
else if(x > p) then
s1 = -x + p * log(x) - log_gamma(p)
res = exp(s1 + log(gpx(p,x)))
else if(x <= p) then
s1 = -x + p * log(abs(x)) - log_gamma(p)
res = one - exp(log(gpx(p, x)) + s1)
end if
end function regamma_q_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for k2, t2 in REAL_KINDS_TYPES[:-1]
impure elemental function regamma_q_${t1[0]}$${k1}$${k2}$(p, x) result(res)
!
! Approximation of regularized incomplet gamma function Q(p,x) for integer p
!
${t1}$, intent(in) :: p
${t2}$, intent(in) :: x
${t2}$ :: res, s1
${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$
if(x < zero) call error_stop("Error(regamma_q): Regularized gamma_q" &
//" function is not defined at x < 0")
if(x == zero) then
res = one
else if(x > real(p, ${k2}$)) then
s1 = -x + p * log(x) - l_gamma(p, one)
res = exp(log(gpx(p,x)) + s1)
elseif(x <= real(p, ${k2}$)) then
s1 = -x + p * log(abs(x)) - l_gamma(p, one)
res = one - exp(s1 + log(gpx(p,x)))
end if
end function regamma_q_${t1[0]}$${k1}$${k2}$
#:endfor
#:endfor
end module stdlib_specialfunctions_gamma
fortran-lang-stdlib-0ede301/src/specialfunctions/stdlib_specialfunctions_legendre.f90 0000664 0001750 0001750 00000004034 15135654166 031426 0 ustar alastair alastair submodule (stdlib_specialfunctions) stdlib_specialfunctions_legendre
implicit none
contains
! derivatives of legegendre polynomials
! unspecified behaviour if n is negative
pure elemental module function dlegendre_fp64(n,x) result(dleg)
integer, intent(in) :: n
real(dp), intent(in) :: x
real(dp) :: dleg
select case(n)
case(0)
dleg = 0
case(1)
dleg = 1
case default
block
real(dp) :: leg_down1, leg_down2, leg
real(dp) :: dleg_down1, dleg_down2
integer :: i
leg_down1 = x
dleg_down1 = 1
leg_down2 = 1
dleg_down2 = 0
do i = 2, n
leg = (2*i-1)*x*leg_down1/i - (i-1)*leg_down2/i
dleg = dleg_down2 + (2*i-1)*leg_down1
leg_down2 = leg_down1
leg_down1 = leg
dleg_down2 = dleg_down1
dleg_down1 = dleg
end do
end block
end select
end function
! legegendre polynomials
! unspecified behaviour if n is negative
pure elemental module function legendre_fp64(n,x) result(leg)
integer, intent(in) :: n
real(dp), intent(in) :: x
real(dp) :: leg
select case(n)
case(0)
leg = 1
case(1)
leg = x
case default
block
real(dp) :: leg_down1, leg_down2
integer :: i
leg_down1 = x
leg_down2 = 1
do i = 2, n
leg = (2*i-1)*x*leg_down1/i - (i-1)*leg_down2/i
leg_down2 = leg_down1
leg_down1 = leg
end do
end block
end select
end function
end submodule
fortran-lang-stdlib-0ede301/src/specialfunctions/CMakeLists.txt 0000664 0001750 0001750 00000000663 15135654166 025073 0 ustar alastair alastair set(specialfunctions_f90Files
stdlib_specialfunctions_legendre.f90
)
set(specialfunctions_fppFiles
stdlib_specialfunctions_activations.fypp
stdlib_specialfunctions.fypp
stdlib_specialfunctions_gamma.fypp
)
configure_stdlib_target(${PROJECT_NAME}_specialfunctions specialfunctions_f90Files specialfunctions_fppFiles "")
target_link_libraries(${PROJECT_NAME}_specialfunctions PUBLIC ${PROJECT_NAME}_intrinsics)
fortran-lang-stdlib-0ede301/src/io/ 0000775 0001750 0001750 00000000000 15135654166 017364 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/io/stdlib_io_npy_load.fypp 0000664 0001750 0001750 00000045067 15135654166 024135 0 ustar alastair alastair ! SPDX-Identifier: MIT
#:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES
!> Implementation of loading npy files into multidimensional arrays
submodule (stdlib_io_npy) stdlib_io_npy_load
use stdlib_error, only : error_stop
use stdlib_strings, only : to_string, starts_with
implicit none
contains
#:for k1, t1 in KINDS_TYPES
#:for rank in RANKS
!> Load a ${rank}$-dimensional array from a npy file
module subroutine load_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg)
!> Name of the npy file to load from
character(len=*), intent(in) :: filename
!> Array to be loaded from the npy file
${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$
!> Error status of loading, zero on success
integer, intent(out), optional :: iostat
!> Associated error message in case of non-zero status code
character(len=:), allocatable, intent(out), optional :: iomsg
character(len=*), parameter :: vtype = type_${t1[0]}$${k1}$
integer, parameter :: rank = ${rank}$
integer :: io, stat
character(len=:), allocatable :: msg
open(newunit=io, file=filename, form="unformatted", access="stream", iostat=stat)
catch: block
character(len=:), allocatable :: this_type
integer, allocatable :: vshape(:)
call get_descriptor(io, filename, this_type, vshape, stat, msg)
if (stat /= 0) exit catch
if (this_type /= vtype) then
stat = 1
msg = "File '"//filename//"' contains data of type '"//this_type//"', "//&
& "but expected '"//vtype//"'"
exit catch
end if
if (size(vshape) /= rank) then
stat = 1
msg = "File '"//filename//"' contains data of rank "//&
& to_string(size(vshape))//", but expected "//&
& to_string(rank)
exit catch
end if
call allocator(array, vshape, stat)
if (stat /= 0) then
msg = "Failed to allocate array of type '"//vtype//"' "//&
& "with total size of "//to_string(product(vshape))
exit catch
end if
read(io, iostat=stat) array
end block catch
close(io)
if (present(iostat)) then
iostat = stat
else if (stat /= 0) then
if (allocated(msg)) then
call error_stop("Failed to read array from file '"//filename//"'"//nl//&
& msg)
else
call error_stop("Failed to read array from file '"//filename//"'")
end if
end if
if (present(iomsg).and.allocated(msg)) call move_alloc(msg, iomsg)
contains
!> Wrapped intrinsic allocate to create an allocation from a shape array
subroutine allocator(array, vshape, stat)
!> Instance of the array to be allocated
${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$
!> Dimensions to allocate for
integer, intent(in) :: vshape(:)
!> Status of allocate
integer, intent(out) :: stat
allocate(array( &
#:for i in range(rank-1)
& vshape(${i+1}$), &
#:endfor
& vshape(${rank}$)), &
& stat=stat)
end subroutine allocator
end subroutine load_npy_${t1[0]}$${k1}$_${rank}$
#:endfor
#:endfor
!> Read the npy header from a binary file and retrieve the descriptor string.
subroutine get_descriptor(io, filename, vtype, vshape, stat, msg)
!> Unformatted, stream accessed unit
integer, intent(in) :: io
!> Filename for error reporting
character(len=*), intent(in) :: filename
!> Type of data saved in npy file
character(len=:), allocatable, intent(out) :: vtype
!> Shape descriptor of the
integer, allocatable, intent(out) :: vshape(:)
!> Status of operation
integer, intent(out) :: stat
!> Associated error message in case of non-zero status
character(len=:), allocatable, intent(out) :: msg
integer :: major, header_len, i
character(len=:), allocatable :: dict
character(len=8) :: header
character :: buf(4)
logical :: fortran_order
! stat should be zero if no error occurred
stat = 0
read(io, iostat=stat) header
if (stat /= 0) return
call parse_header(header, major, stat, msg)
if (stat /= 0) return
read(io, iostat=stat) buf(1:merge(4, 2, major > 1))
if (stat /= 0) return
if (major > 1) then
header_len = ichar(buf(1)) &
& + ichar(buf(2)) * 256**1 &
& + ichar(buf(3)) * 256**2 &
& + ichar(buf(4)) * 256**3
else
header_len = ichar(buf(1)) &
& + ichar(buf(2)) * 256**1
end if
allocate(character(header_len) :: dict, stat=stat)
if (stat /= 0) return
read(io, iostat=stat) dict
if (stat /= 0) return
if (dict(header_len:header_len) /= nl) then
stat = 1
msg = "Descriptor length does not match"
return
end if
if (scan(dict, achar(0)) > 0) then
stat = 1
msg = "Nul byte not allowed in descriptor string"
return
end if
call parse_descriptor(trim(dict(:len(dict)-1)), filename, &
& vtype, fortran_order, vshape, stat, msg)
if (stat /= 0) return
if (.not.fortran_order) then
vshape = [(vshape(i), i = size(vshape), 1, -1)]
end if
end subroutine get_descriptor
!> Parse the first eight bytes of the npy header to verify the data
subroutine parse_header(header, major, stat, msg)
!> Header of the binary file
character(len=*), intent(in) :: header
!> Major version of the npy format
integer, intent(out) :: major
!> Status of operation
integer, intent(out) :: stat
!> Associated error message in case of non-zero status
character(len=:), allocatable, intent(out) :: msg
integer :: minor
! stat should be zero if no error occurred
stat = 0
if (header(1:1) /= magic_number) then
stat = 1
msg = "Expected z'93' but got z'"//to_string(ichar(header(1:1)))//"' "//&
& "as first byte"
return
end if
if (header(2:6) /= magic_string) then
stat = 1
msg = "Expected identifier '"//magic_string//"'"
return
end if
major = ichar(header(7:7))
if (.not.any(major == [1, 2, 3])) then
stat = 1
msg = "Unsupported format major version number '"//to_string(major)//"'"
return
end if
minor = ichar(header(8:8))
if (minor /= 0) then
stat = 1
msg = "Unsupported format version "// &
& "'"//to_string(major)//"."//to_string(minor)//"'"
return
end if
end subroutine parse_header
!> Parse the descriptor in the npy header. This routine implements a minimal
!> non-recursive parser for serialized Python dictionaries.
subroutine parse_descriptor(input, filename, vtype, fortran_order, vshape, stat, msg)
!> Input string to parse as descriptor
character(len=*), intent(in) :: input
!> Filename for error reporting
character(len=*), intent(in) :: filename
!> Type of the data stored, retrieved from field `descr`
character(len=:), allocatable, intent(out) :: vtype
!> Whether the data is in left layout, retrieved from field `fortran_order`
logical, intent(out) :: fortran_order
!> Shape of the stored data, retrieved from field `shape`
integer, allocatable, intent(out) :: vshape(:)
!> Status of operation
integer, intent(out) :: stat
!> Associated error message in case of non-zero status
character(len=:), allocatable, intent(out) :: msg
enum, bind(c)
enumerator :: invalid, string, lbrace, rbrace, comma, colon, &
lparen, rparen, bool, literal, space
end enum
type :: token_type
integer :: first, last, kind
end type token_type
integer :: pos
character(len=:), allocatable :: key
type(token_type) :: token, last
logical :: has_descr, has_shape, has_fortran_order
has_descr = .false.
has_shape = .false.
has_fortran_order = .false.
pos = 0
call next_token(input, pos, token, [lbrace], stat, msg)
if (stat /= 0) return
last = token_type(pos, pos, comma)
do while (pos < len(input))
call get_token(input, pos, token)
select case(token%kind)
case(space)
continue
case(comma)
if (token%kind == last%kind) then
stat = 1
msg = make_message(filename, input, token%first, token%last, &
& "Comma cannot appear at this point")
return
end if
last = token
case(rbrace)
exit
case(string)
if (token%kind == last%kind) then
stat = 1
msg = make_message(filename, input, token%first, token%last, &
& "String cannot appear at this point")
return
end if
last = token
key = input(token%first+1:token%last-1)
call next_token(input, pos, token, [colon], stat, msg)
if (stat /= 0) return
if (key == "descr" .and. has_descr &
& .or. key == "fortran_order" .and. has_fortran_order &
& .or. key == "shape" .and. has_shape) then
stat = 1
msg = make_message(filename, input, last%first, last%last, &
& "Duplicate entry for '"//key//"' found")
return
end if
select case(key)
case("descr")
call next_token(input, pos, token, [string], stat, msg)
if (stat /= 0) return
vtype = input(token%first+1:token%last-1)
has_descr = .true.
case("fortran_order")
call next_token(input, pos, token, [bool], stat, msg)
if (stat /= 0) return
fortran_order = input(token%first:token%last) == "True"
has_fortran_order = .true.
case("shape")
call parse_tuple(input, pos, vshape, stat, msg)
has_shape = .true.
case default
stat = 1
msg = make_message(filename, input, last%first, last%last, &
& "Invalid entry '"//key//"' in dictionary encountered")
return
end select
case default
stat = 1
msg = make_message(filename, input, token%first, token%last, &
& "Invalid token encountered")
return
end select
end do
if (.not.has_descr) then
stat = 1
msg = make_message(filename, input, 1, pos, &
& "Dictionary does not contain required entry 'descr'")
end if
if (.not.has_shape) then
stat = 1
msg = make_message(filename, input, 1, pos, &
& "Dictionary does not contain required entry 'shape'")
end if
if (.not.has_fortran_order) then
stat = 1
msg = make_message(filename, input, 1, pos, &
& "Dictionary does not contain required entry 'fortran_order'")
end if
contains
function make_message(filename, input, first, last, message) result(str)
!> Filename for context
character(len=*), intent(in) :: filename
!> Input string to parse
character(len=*), intent(in) :: input
!> Offset in the input
integer, intent(in) :: first, last
!> Error message
character(len=*), intent(in) :: message
!> Final output message
character(len=:), allocatable :: str
character(len=*), parameter :: nl = new_line('a')
str = message // nl // &
& " --> " // filename // ":1:" // to_string(first) // "-" // to_string(last) // nl // &
& " |" // nl // &
& "1 | " // input // nl // &
& " |" // repeat(" ", first) // repeat("^", last - first + 1) // nl // &
& " |"
end function make_message
!> Parse a tuple of integers into an array of integers
subroutine parse_tuple(input, pos, tuple, stat, msg)
!> Input string to parse
character(len=*), intent(in) :: input
!> Offset in the input, will be advanced after reading
integer, intent(inout) :: pos
!> Array representing tuple of integers
integer, allocatable, intent(out) :: tuple(:)
!> Status of operation
integer, intent(out) :: stat
!> Associated error message in case of non-zero status
character(len=:), allocatable, intent(out) :: msg
type(token_type) :: token
integer :: last, itmp
allocate(tuple(0), stat=stat)
if (stat /= 0) return
call next_token(input, pos, token, [lparen], stat, msg)
if (stat /= 0) return
last = comma
do while (pos < len(input))
call get_token(input, pos, token)
select case(token%kind)
case(space)
continue
case(literal)
if (token%kind == last) then
stat = 1
msg = make_message(filename, input, token%first, token%last, &
& "Invalid token encountered")
return
end if
last = token%kind
read(input(token%first:token%last), *, iostat=stat) itmp
if (stat /= 0) then
return
end if
tuple = [tuple, itmp]
case(comma)
if (token%kind == last) then
stat = 1
msg = make_message(filename, input, token%first, token%last, &
& "Invalid token encountered")
return
end if
last = token%kind
case(rparen)
exit
case default
stat = 1
msg = make_message(filename, input, token%first, token%last, &
& "Invalid token encountered")
return
end select
end do
end subroutine parse_tuple
!> Get the next allowed token
subroutine next_token(input, pos, token, allowed_token, stat, msg)
!> Input string to parse
character(len=*), intent(in) :: input
!> Current offset in the input string
integer, intent(inout) :: pos
!> Last token parsed
type(token_type), intent(out) :: token
!> Tokens allowed in the current context
integer, intent(in) :: allowed_token(:)
!> Status of operation
integer, intent(out) :: stat
!> Associated error message in case of non-zero status
character(len=:), allocatable, intent(out) :: msg
stat = pos
do while (pos < len(input))
call get_token(input, pos, token)
if (token%kind == space) then
continue
else if (any(token%kind == allowed_token)) then
stat = 0
exit
else
stat = 1
msg = make_message(filename, input, token%first, token%last, &
& "Invalid token encountered")
exit
end if
end do
end subroutine next_token
!> Tokenize input string
subroutine get_token(input, pos, token)
!> Input strin to tokenize
character(len=*), intent(in) :: input
!> Offset in input string, will be advanced
integer, intent(inout) :: pos
!> Returned token from the next position
type(token_type), intent(out) :: token
character :: quote
pos = pos + 1
select case(input(pos:pos))
case("""", "'")
quote = input(pos:pos)
token%first = pos
pos = pos + 1
do while (pos <= len(input))
if (input(pos:pos) == quote) then
token%last = pos
exit
else
pos = pos + 1
end if
end do
token%kind = string
case("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
token%first = pos
do while (pos <= len(input))
if (.not.any(input(pos:pos) == ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"])) then
pos = pos - 1
token%last = pos
exit
else
pos = pos + 1
end if
end do
token%kind = literal
case("T")
if (starts_with(input(pos:), "True")) then
token = token_type(pos, pos+3, bool)
pos = pos + 3
else
token = token_type(pos, pos, invalid)
end if
case("F")
if (starts_with(input(pos:), "False")) then
token = token_type(pos, pos+4, bool)
pos = pos + 4
else
token = token_type(pos, pos, invalid)
end if
case("{")
token = token_type(pos, pos, lbrace)
case("}")
token = token_type(pos, pos, rbrace)
case(",")
token = token_type(pos, pos, comma)
case(":")
token = token_type(pos, pos, colon)
case("(")
token = token_type(pos, pos, lparen)
case(")")
token = token_type(pos, pos, rparen)
case(" ", nl)
token = token_type(pos, pos, space)
case default
token = token_type(pos, pos, invalid)
end select
end subroutine get_token
end subroutine parse_descriptor
end submodule stdlib_io_npy_load
fortran-lang-stdlib-0ede301/src/io/stdlib_io_npy.fypp 0000664 0001750 0001750 00000011726 15135654166 023131 0 ustar alastair alastair ! SPDX-Identifer: MIT
#:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES
!> Description of the npy format taken from
!> https://numpy.org/doc/stable/reference/generated/numpy.lib.format.html
!>
!>## Format Version 1.0
!>
!> The first 6 bytes are a magic string: exactly \x93NUMPY.
!>
!> The next 1 byte is an unsigned byte:
!> the major version number of the file format, e.g. \x01.
!>
!> The next 1 byte is an unsigned byte:
!> the minor version number of the file format, e.g. \x00.
!> Note: the version of the file format is not tied to the version of the numpy package.
!>
!> The next 2 bytes form a little-endian unsigned short int:
!> the length of the header data HEADER_LEN.
!>
!> The next HEADER_LEN bytes form the header data describing the array’s format.
!> It is an ASCII string which contains a Python literal expression of a dictionary.
!> It is terminated by a newline (\n) and padded with spaces (\x20) to make the total
!> of len(magic string) + 2 + len(length) + HEADER_LEN be evenly divisible by 64 for
!> alignment purposes.
!>
!> The dictionary contains three keys:
!>
!> - “descr”: dtype.descr
!> An object that can be passed as an argument to the numpy.dtype constructor
!> to create the array’s dtype.
!>
!> - “fortran_order”: bool
!> Whether the array data is Fortran-contiguous or not. Since Fortran-contiguous
!> arrays are a common form of non-C-contiguity, we allow them to be written directly
!> to disk for efficiency.
!>
!> - “shape”: tuple of int
!> The shape of the array.
!>
!> For repeatability and readability, the dictionary keys are sorted in alphabetic order.
!> This is for convenience only. A writer SHOULD implement this if possible. A reader MUST
!> NOT depend on this.
!>
!> Following the header comes the array data. If the dtype contains Python objects
!> (i.e. dtype.hasobject is True), then the data is a Python pickle of the array.
!> Otherwise the data is the contiguous (either C- or Fortran-, depending on fortran_order)
!> bytes of the array. Consumers can figure out the number of bytes by multiplying the
!> number of elements given by the shape (noting that shape=() means there is 1 element)
!> by dtype.itemsize.
!>
!>## Format Version 2.0
!>
!> The version 1.0 format only allowed the array header to have a total size of 65535 bytes.
!> This can be exceeded by structured arrays with a large number of columns.
!> The version 2.0 format extends the header size to 4 GiB. numpy.save will automatically
!> save in 2.0 format if the data requires it, else it will always use the more compatible
!> 1.0 format.
!>
!> The description of the fourth element of the header therefore has become:
!> “The next 4 bytes form a little-endian unsigned int: the length of the header data
!> HEADER_LEN.”
!>
!>## Format Version 3.0
!>
!> This version replaces the ASCII string (which in practice was latin1) with a
!> utf8-encoded string, so supports structured types with any unicode field names.
module stdlib_io_npy
use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, xdp, qp
implicit none
private
public :: save_npy, load_npy
!> Version: experimental
!>
!> Save multidimensional array in npy format
!> ([Specification](../page/specs/stdlib_io.html#save_npy))
interface save_npy
#:for k1, t1 in KINDS_TYPES
#:for rank in RANKS
module subroutine save_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg)
character(len=*), intent(in) :: filename
${t1}$, intent(in) :: array${ranksuffix(rank)}$
integer, intent(out), optional :: iostat
character(len=:), allocatable, intent(out), optional :: iomsg
end subroutine save_npy_${t1[0]}$${k1}$_${rank}$
#:endfor
#:endfor
end interface save_npy
!> Version: experimental
!>
!> Load multidimensional array in npy format
!> ([Specification](../page/specs/stdlib_io.html#load_npy))
interface load_npy
#:for k1, t1 in KINDS_TYPES
#:for rank in RANKS
module subroutine load_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg)
character(len=*), intent(in) :: filename
${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$
integer, intent(out), optional :: iostat
character(len=:), allocatable, intent(out), optional :: iomsg
end subroutine load_npy_${t1[0]}$${k1}$_${rank}$
#:endfor
#:endfor
end interface load_npy
character(len=*), parameter :: nl = achar(10)
character(len=*), parameter :: &
type_iint8 = " Default delimiter for loadtxt, savetxt and number_of_columns
character(len=1), parameter :: delimiter_default = " "
public :: FMT_INT, FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_XDP, FMT_REAL_QP
public :: FMT_COMPLEX_SP, FMT_COMPLEX_DP, FMT_COMPLEX_XDP, FMT_COMPLEX_QP
!> Version: experimental
!>
!> Read a whole line from a formatted unit into a string variable
interface get_line
module procedure :: get_line_char
module procedure :: get_line_string
module procedure :: get_line_input_char
module procedure :: get_line_input_string
end interface get_line
interface loadtxt
!! version: experimental
!!
!! Loads a 2D array from a text file
!! ([Specification](../page/specs/stdlib_io.html#description))
#:for k1, t1 in KINDS_TYPES
module procedure loadtxt_${t1[0]}$${k1}$
#:endfor
end interface loadtxt
interface savetxt
!! version: experimental
!!
!! Saves a 2D array into a text file
!! ([Specification](../page/specs/stdlib_io.html#description_2))
#:for k1, t1 in KINDS_TYPES
module procedure savetxt_${t1[0]}$${k1}$
#:endfor
end interface
contains
#:for k1, t1 in KINDS_TYPES
subroutine loadtxt_${t1[0]}$${k1}$(filename, d, skiprows, max_rows, fmt, delimiter)
!! version: experimental
!!
!! Loads a 2D array from a text file.
!!
!! Arguments
!! ---------
!!
!! Filename to load the array from
character(len=*), intent(in) :: filename
!! The array 'd' will be automatically allocated with the correct dimensions
${t1}$, allocatable, intent(out) :: d(:,:)
!! Skip the first `skiprows` lines. If skipping more rows than present, a 0-sized array will be returned. The default is 0.
integer, intent(in), optional :: skiprows
!! Read `max_rows` lines of content after `skiprows` lines.
!! A negative value results in reading all lines.
!! A value of zero results in no lines to be read.
!! The default value is -1.
integer, intent(in), optional :: max_rows
character(len=*), intent(in), optional :: fmt
character(len=1), intent(in), optional :: delimiter
character(len=:), allocatable :: fmt_
character(len=1) :: delimiter_
!!
!! Example
!! -------
!!
!!```fortran
!! ${t1}$, allocatable :: data(:, :)
!! call loadtxt("log.txt", data) ! 'data' will be automatically allocated
!!```
!!
!! Where 'log.txt' contains for example::
!!
!! 1 2 3
!! 2 4 6
!! 8 9 10
!! 11 12 13
!! ...
!!
integer :: s
integer :: nrow, ncol, i, j, ios, skiprows_, max_rows_, istart, iend
character(len=:), allocatable :: line, iomsg_
character(len=1024) :: iomsg, msgout
skiprows_ = max(optval(skiprows, 0), 0)
max_rows_ = optval(max_rows, -1)
delimiter_ = optval(delimiter, delimiter_default)
s = open(filename)
! determine number or rows
nrow = number_of_rows(s)
skiprows_ = min(skiprows_, nrow)
if ( max_rows_ < 0 .or. max_rows_ > (nrow - skiprows_) ) max_rows_ = nrow - skiprows_
! determine number of columns
ncol = 0
if ( skiprows_ < nrow ) ncol = number_of_columns(s, skiprows=skiprows_, delimiter=delimiter_)
#:if 'complex' in t1
ncol = ncol / 2
#:endif
allocate(d(max_rows_, ncol))
if (max_rows_ == 0 .or. ncol == 0) return
do i = 1, skiprows_
read(s, *, iostat=ios, iomsg=iomsg)
if (ios/=0) then
write(msgout,1) trim(iomsg),i,trim(filename)
1 format('loadtxt: error <',a,'> skipping line ',i0,' of ',a,'.')
call error_stop(msg=trim(msgout))
end if
end do
! Default to format used for savetxt if fmt not specified.
#:if 'real' in t1
fmt_ = optval(fmt, "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",:,1x))")
#:elif 'complex' in t1
fmt_ = optval(fmt, "(*"//FMT_COMPLEX_${k1}$(1:len(FMT_COMPLEX_${k1}$)-1)//",:,1x))")
#:else
fmt_ = optval(fmt, "*")
#:endif
if ( fmt_ == '*' ) then
! Use list directed read if user has specified fmt='*'
if (is_blank(delimiter_) .or. delimiter_ == ",") then
do i = 1, max_rows_
read (s,*,iostat=ios,iomsg=iomsg) d(i, :)
if (ios/=0) then
write(msgout,2) trim(iomsg),size(d,2),i,trim(filename)
call error_stop(msg=trim(msgout))
end if
enddo
! Otherwise read each value separately
else
do i = 1, max_rows_
call get_line(s, line, ios, iomsg_)
if (ios/=0) then
write(msgout,2) trim(iomsg_),size(d,2),i,trim(filename)
call error_stop(msg=trim(msgout))
end if
istart = 0
do j = 1, ncol - 1
iend = index(line(istart+1:), delimiter_)
read (line(istart+1:istart+iend-1),*,iostat=ios,iomsg=iomsg) d(i, j)
if (ios/=0) then
write(msgout,2) trim(iomsg),size(d,2),i,trim(filename)
call error_stop(msg=trim(msgout))
end if
istart = istart + iend
end do
read (line(istart+1:),*,iostat=ios,iomsg=iomsg) d(i, ncol)
if (ios/=0) then
write(msgout,2) trim(iomsg),size(d,2),i,trim(filename)
call error_stop(msg=trim(msgout))
end if
enddo
end if
else
! Otherwise pass default or user specified fmt string.
do i = 1, max_rows_
read (s,fmt_,iostat=ios,iomsg=iomsg) d(i, :)
if (ios/=0) then
write(msgout,2) trim(iomsg),size(d,2),i,trim(filename)
call error_stop(msg=trim(msgout))
end if
enddo
endif
close(s)
2 format('loadtxt: error <',a,'> reading ',i0,' values from line ',i0,' of ',a,'.')
end subroutine loadtxt_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in KINDS_TYPES
subroutine savetxt_${t1[0]}$${k1}$(filename, d, delimiter)
!! version: experimental
!!
!! Saves a 2D array into a text file.
!!
!! Arguments
!! ---------
!!
character(len=*), intent(in) :: filename ! File to save the array to
${t1}$, intent(in) :: d(:,:) ! The 2D array to save
character(len=1), intent(in), optional :: delimiter ! Column delimiter. Default is a space.
!!
!! Example
!! -------
!!
!!```fortran
!! ${t1}$ :: data(3, 2)
!! call savetxt("log.txt", data)
!!```
!!
integer :: s, i, ios
character(len=1) :: delimiter_
character(len=3) :: delim_str
character(len=:), allocatable :: fmt_
character(len=1024) :: iomsg, msgout
delimiter_ = optval(delimiter, delimiter_default)
delim_str = "'"//delimiter_//"'"
#:if 'real' in t1
fmt_ = "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",:,"//delim_str//"))"
#:elif 'complex' in t1
fmt_ = "(*"//FMT_COMPLEX_${k1}$(1:11)//delim_str//FMT_COMPLEX_${k1}$(14:23)//",:,"//delim_str//"))"
#:elif 'integer' in t1
fmt_ = "(*"//FMT_INT(1:len(FMT_INT)-1)//",:,"//delim_str//"))"
#:endif
s = open(filename, "w")
do i = 1, size(d, 1)
#:if 'real' in t1 or 'complex' in t1 or 'integer' in t1
write(s, fmt_, &
#:else
write(s, *, &
#:endif
iostat=ios,iomsg=iomsg) d(i, :)
if (ios/=0) then
write(msgout,1) trim(iomsg),size(d,2),i,trim(filename)
call error_stop(msg=trim(msgout))
end if
end do
close(s)
1 format('savetxt: error <',a,'> writing ',i0,' values to line ',i0,' of ',a,'.')
end subroutine savetxt_${t1[0]}$${k1}$
#:endfor
integer function number_of_columns(s, skiprows, delimiter)
!! version: experimental
!!
!! determine number of columns
integer,intent(in) :: s
integer, intent(in), optional :: skiprows
character(len=1), intent(in), optional :: delimiter
integer :: ios, skiprows_, i
character :: c
character(len=:), allocatable :: line
character(len=1) :: delimiter_
logical :: last_delim
skiprows_ = optval(skiprows, 0)
delimiter_ = optval(delimiter, delimiter_default)
rewind(s)
do i = 1, skiprows_
read(s, *)
end do
number_of_columns = 0
! Read first non-skipped line as a whole
call get_line(s, line, ios)
if (ios/=0 .or. .not.allocated(line)) return
last_delim = .true.
if (delimiter_ == delimiter_default) then
do i = 1,len(line)
c = line(i:i)
if (last_delim .and. .not. is_blank(c)) number_of_columns = number_of_columns + 1
last_delim = is_blank(c)
end do
else
do i = 1,len(line)
if (line(i:i) == delimiter_) number_of_columns = number_of_columns + 1
end do
if (number_of_columns == 0) then
if (len_trim(line) /= 0) number_of_columns = 1
else
number_of_columns = number_of_columns + 1
end if
end if
rewind(s)
end function number_of_columns
integer function number_of_rows(s) result(nrows)
!! version: experimental
!!
!! Determine the number or rows in a file
integer, intent(in)::s
integer :: ios
rewind(s)
nrows = 0
do
read(s, *, iostat=ios)
if (ios /= 0) exit
nrows = nrows + 1
end do
rewind(s)
end function number_of_rows
integer function open(filename, mode, iostat) result(u)
!! version: experimental
!!
!! Opens a file
!! ([Specification](../page/specs/stdlib_io.html#description_1))
!!
!!##### Behavior
!!
!!
!! To open a file to read:
!!
!!```fortran
!! u = open("somefile.txt") ! The default `mode` is "rt"
!! u = open("somefile.txt", "r")
!!```
!!
!! To open a file to write:
!!
!!```fortran
!! u = open("somefile.txt", "w")
!!```
!!
!! To append to the end of the file if it exists:
!!
!!```fortran
!! u = open("somefile.txt", "a")
!!```
character(*), intent(in) :: filename
character(*), intent(in), optional :: mode
integer, intent(out), optional :: iostat
character(3) :: mode_
character(:),allocatable :: action_, position_, status_, access_, form_
mode_ = parse_mode(optval(mode, ""))
select case (mode_(1:2))
case('r')
action_='read'
position_='asis'
status_='old'
case('w')
action_='write'
position_='asis'
status_='replace'
case('a')
action_='write'
position_='append'
status_='old'
case('x')
action_='write'
position_='asis'
status_='new'
case('r+')
action_='readwrite'
position_='asis'
status_='old'
case('w+')
action_='readwrite'
position_='asis'
status_='replace'
case('a+')
action_='readwrite'
position_='append'
status_='old'
case('x+')
action_='readwrite'
position_='asis'
status_='new'
case default
call error_stop("Unsupported mode: "//mode_(1:2))
end select
select case (mode_(3:3))
case('t')
form_='formatted'
access_='sequential'
case('b')
form_='unformatted'
access_ = 'stream'
case default
call error_stop("Unsupported mode: "//mode_(3:3))
end select
if (present(iostat)) then
open(newunit=u, file=filename, &
action = action_, position = position_, status = status_, &
access = access_, form = form_, &
iostat = iostat)
else
open(newunit=u, file=filename, &
action = action_, position = position_, status = status_, &
access = access_, form = form_)
end if
end function open
character(3) function parse_mode(mode) result(mode_)
character(*), intent(in) :: mode
integer :: i
character(:),allocatable :: a
logical :: lfirst(3)
mode_ = 'r t'
if (len_trim(mode) == 0) return
a=trim(adjustl(mode))
lfirst = .true.
do i=1,len(a)
if (lfirst(1) &
.and. (a(i:i) == 'r' .or. a(i:i) == 'w' .or. a(i:i) == 'a' .or. a(i:i) == 'x') &
) then
mode_(1:1) = a(i:i)
lfirst(1)=.false.
else if (lfirst(2) .and. a(i:i) == '+') then
mode_(2:2) = a(i:i)
lfirst(2)=.false.
else if (lfirst(3) .and. (a(i:i) == 't' .or. a(i:i) == 'b')) then
mode_(3:3) = a(i:i)
lfirst(3)=.false.
else if (a(i:i) == ' ') then
cycle
else if(any(.not.lfirst)) then
call error_stop("Wrong mode: "//trim(a))
else
call error_stop("Wrong character: "//a(i:i))
endif
end do
end function parse_mode
!> Version: experimental
!>
!> Read a whole line from a formatted unit into a deferred length character variable
subroutine get_line_char(unit, line, iostat, iomsg)
!> Formatted IO unit
integer, intent(in) :: unit
!> Line to read
character(len=:), allocatable, intent(out) :: line
!> Status of operation
integer, intent(out), optional :: iostat
!> Error message
character(len=:), allocatable, optional :: iomsg
integer, parameter :: bufsize = 4096
character(len=bufsize) :: buffer, msg
integer :: chunk, stat
logical :: opened
if (unit /= -1) then
inquire(unit=unit, opened=opened)
else
opened = .false.
end if
if (opened) then
open(unit=unit, pad="yes", iostat=stat, iomsg=msg)
else
stat = 1
msg = "Unit is not connected"
end if
line = ""
do while (stat == 0)
read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=chunk) buffer
if (stat > 0) exit
line = line // buffer(:chunk)
end do
if (is_iostat_eor(stat)) stat = 0
if (stat /= 0 .and. present(iomsg)) iomsg = trim(msg)
if (present(iostat)) then
iostat = stat
else if (stat /= 0) then
call error_stop(trim(msg))
end if
end subroutine get_line_char
!> Version: experimental
!>
!> Read a whole line from a formatted unit into a string variable
subroutine get_line_string(unit, line, iostat, iomsg)
!> Formatted IO unit
integer, intent(in) :: unit
!> Line to read
type(string_type), intent(out) :: line
!> Status of operation
integer, intent(out), optional :: iostat
!> Error message
character(len=:), allocatable, optional :: iomsg
character(len=:), allocatable :: buffer
call get_line(unit, buffer, iostat, iomsg)
line = string_type(buffer)
end subroutine get_line_string
!> Version: experimental
!>
!> Read a whole line from the standard input into a deferred length character variable
subroutine get_line_input_char(line, iostat, iomsg)
!> Line to read
character(len=:), allocatable, intent(out) :: line
!> Status of operation
integer, intent(out), optional :: iostat
!> Error message
character(len=:), allocatable, optional :: iomsg
call get_line(input_unit, line, iostat, iomsg)
end subroutine get_line_input_char
!> Version: experimental
!>
!> Read a whole line from the standard input into a string variable
subroutine get_line_input_string(line, iostat, iomsg)
!> Line to read
type(string_type), intent(out) :: line
!> Status of operation
integer, intent(out), optional :: iostat
!> Error message
character(len=:), allocatable, optional :: iomsg
call get_line(input_unit, line, iostat, iomsg)
end subroutine get_line_input_string
!> Version: experimental
!>
!> Reads a whole ASCII file and loads its contents into a string variable.
!> The function handles error states and optionally deletes the file after reading.
subroutine get_file_string(filename,file,err,delete)
!> Input file name
character(*), intent(in) :: filename
!> Output string variable
type(string_type), intent(out) :: file
!> [optional] State return flag. On error, if not requested, the code will stop.
type(state_type), optional, intent(out) :: err
!> [optional] Delete file after reading? Default: do not delete
logical, optional, intent(in) :: delete
! Local variables
character(len=:), allocatable :: filestring
! Process output
call get_file_char(filename,filestring,err,delete)
call move(from=fileString,to=file)
end subroutine get_file_string
!> Version: experimental
!>
!> Reads a whole ASCII file and loads its contents into an allocatable `character` variable.
!> The function handles error states and optionally deletes the file after reading.
subroutine get_file_char(filename,file,err,delete)
!> Input file name
character(*), intent(in) :: filename
!> Output string variable
character(len=:), allocatable, intent(out) :: file
!> [optional] State return flag. On error, if not requested, the code will stop.
type(state_type), optional, intent(out) :: err
!> [optional] Delete file after reading? Default: do not delete
logical, optional, intent(in) :: delete
! Local variables
type(state_type) :: err0
character(len=512) :: iomsg
integer :: lun,iostat
integer(int64) :: errpos,file_size
logical :: is_present,want_deleted
!> Check if the file should be deleted after reading
if (present(delete)) then
want_deleted = delete
else
want_deleted = .false.
end if
!> Check file existing
inquire(file=filename, exist=is_present)
if (.not.is_present) then
allocate(character(len=0) :: file)
err0 = state_type('get_file',STDLIB_IO_ERROR,'File not present:',filename)
call err0%handle(err)
return
end if
!> Retrieve file size
inquire(file=filename,size=file_size)
invalid_size: if (file_size<0) then
allocate(character(len=0) :: file)
err0 = state_type('get_file',STDLIB_IO_ERROR,filename,'has invalid size=',file_size)
call err0%handle(err)
return
endif invalid_size
! Read file
open(newunit=lun,file=filename, &
form='unformatted',action='read',access='stream',status='old', &
iostat=iostat,iomsg=iomsg)
if (iostat/=0) then
allocate(character(len=0) :: file)
err0 = state_type('get_file',STDLIB_IO_ERROR,'Cannot open',filename,'for read:',iomsg)
call err0%handle(err)
return
end if
allocate(character(len=file_size) :: file)
read_data: if (file_size>0) then
read(lun, pos=1, iostat=iostat, iomsg=iomsg) file
! Read error
if (iostat/=0) then
inquire(unit=lun,pos=errpos)
err0 = state_type('get_file',STDLIB_IO_ERROR,iomsg,'(',filename,'at byte',errpos,')')
call err0%handle(err)
return
endif
end if read_data
if (want_deleted) then
close(lun,iostat=iostat,status='delete')
if (iostat/=0) err0 = state_type('get_file',STDLIB_IO_ERROR,'Cannot delete',filename,'after reading')
else
close(lun,iostat=iostat)
if (iostat/=0) err0 = state_type('get_file',STDLIB_IO_ERROR,'Cannot close',filename,'after reading')
endif
! Process output
call err0%handle(err)
end subroutine get_file_char
end module stdlib_io
fortran-lang-stdlib-0ede301/src/io/stdlib_io_npy_save.fypp 0000664 0001750 0001750 00000011043 15135654166 024137 0 ustar alastair alastair ! SPDX-Identifer: MIT
#:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES
!> Implementation of saving multidimensional arrays to npy files
submodule (stdlib_io_npy) stdlib_io_npy_save
use stdlib_error, only : error_stop
use stdlib_strings, only : to_string
implicit none
contains
!> Generate magic header string for npy format
pure function magic_header(major, minor) result(str)
!> Major version of npy format
integer, intent(in) :: major
!> Minor version of npy format
integer, intent(in) :: minor
!> Magic string for npy format
character(len=8) :: str
str = magic_number // magic_string // achar(major) // achar(minor)
end function magic_header
!> Generate header for npy format
pure function npy_header(vtype, vshape) result(str)
!> Type of variable
character(len=*), intent(in) :: vtype
!> Shape of variable
integer, intent(in) :: vshape(:)
!> Header string for npy format
character(len=:), allocatable :: str
integer, parameter :: len_v10 = 8 + 2, len_v20 = 8 + 4, block_size = 64
str = &
"{'descr': '"//vtype//&
"', 'fortran_order': True, 'shape': "//&
shape_str(vshape)//", }"
if (len(str) + len_v10 >= 65535) then
str = str // &
& repeat(" ", block_size - mod(len(str) + len_v20 + 1, block_size)) // nl
str = magic_header(2, 0) // to_bytes_i4(int(len(str))) // str
else
str = str // &
& repeat(" ", block_size - mod(len(str) + len_v10 + 1, block_size)) // nl
str = magic_header(1, 0) // to_bytes_i2(int(len(str))) // str
end if
end function npy_header
!> Write integer as byte string in little endian encoding
pure function to_bytes_i4(val) result(str)
!> Integer value to convert to bytes
integer, intent(in) :: val
!> String of bytes
character(len=4) :: str
str = achar(mod(val, 256**1)) // &
& achar(mod(val, 256**2) / 256**1) // &
& achar(mod(val, 256**3) / 256**2) // &
& achar(val / 256**3)
end function to_bytes_i4
!> Write integer as byte string in little endian encoding, 2-byte truncated version
pure function to_bytes_i2(val) result(str)
!> Integer value to convert to bytes
integer, intent(in) :: val
!> String of bytes
character(len=2) :: str
str = achar(mod(val, 2**8)) // &
& achar(mod(val, 2**16) / 2**8)
end function to_bytes_i2
!> Print array shape as tuple of int
pure function shape_str(vshape) result(str)
!> Shape of variable
integer, intent(in) :: vshape(:)
!> Shape string for npy format
character(len=:), allocatable :: str
integer :: i
str = "("
do i = 1, size(vshape)
str = str//to_string(vshape(i))//", "
enddo
str = str//")"
end function shape_str
#:for k1, t1 in KINDS_TYPES
#:for rank in RANKS
!> Save ${rank}$-dimensional array in npy format
module subroutine save_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg)
!> Name of the npy file to load from
character(len=*), intent(in) :: filename
!> Array to be loaded from the npy file
${t1}$, intent(in) :: array${ranksuffix(rank)}$
!> Error status of loading, zero on success
integer, intent(out), optional :: iostat
!> Associated error message in case of non-zero status code
character(len=:), allocatable, intent(out), optional :: iomsg
character(len=*), parameter :: vtype = type_${t1[0]}$${k1}$
integer :: io, stat
open(newunit=io, file=filename, form="unformatted", access="stream", iostat=stat)
if (stat == 0) then
write(io, iostat=stat) npy_header(vtype, shape(array))
end if
if (stat == 0) then
write(io, iostat=stat) array
end if
close(io, iostat=stat)
if (present(iostat)) then
iostat = stat
else if (stat /= 0) then
call error_stop("Failed to write array to file '"//filename//"'")
end if
if (present(iomsg)) then
if (stat /= 0) then
iomsg = "Failed to write array to file '"//filename//"'"
end if
end if
end subroutine save_npy_${t1[0]}$${k1}$_${rank}$
#:endfor
#:endfor
end submodule stdlib_io_npy_save
fortran-lang-stdlib-0ede301/src/selection/ 0000775 0001750 0001750 00000000000 15135654166 020742 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/selection/CMakeLists.txt 0000664 0001750 0001750 00000000456 15135654166 023507 0 ustar alastair alastair set(selection_fppFiles
stdlib_selection.fypp
)
set(selection_cppFiles
)
set(selection_f90Files
)
configure_stdlib_target(${PROJECT_NAME}_selection selection_f90Files selection_fppFiles selection_cppFiles)
target_link_libraries(${PROJECT_NAME}_selection PUBLIC ${PROJECT_NAME}_core)
fortran-lang-stdlib-0ede301/src/selection/stdlib_selection.fypp 0000664 0001750 0001750 00000026022 15135654166 025172 0 ustar alastair alastair #:include "common.fypp"
! Specify kinds/types for the input array in select and arg_select
#:set ARRAY_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES
! The index arrays are of all INT_KINDS_TYPES
module stdlib_selection
!! Quickly find the k-th smallest value of an array, or the index of the k-th smallest value.
!! ([Specification](../page/specs/stdlib_selection.html))
!
! This code was modified from the "Coretran" implementation "quickSelect" by
! Leon Foks, https://github.com/leonfoks/coretran/tree/HEAD/src/sorting
!
! Leon Foks gave permission to release this code under stdlib's MIT license.
! (https://github.com/fortran-lang/stdlib/pull/500#commitcomment-57418593)
!
use stdlib_kinds
implicit none
private
public :: select, arg_select
interface select
!! version: experimental
!! ([Specification](..//page/specs/stdlib_selection.html#select-find-the-k-th-smallest-value-in-an-input-array))
#:for arraykind, arraytype in ARRAY_KINDS_TYPES
#:for intkind, inttype in INT_KINDS_TYPES
#:set name = rname("select", 1, arraytype, arraykind, intkind)
module procedure ${name}$
#:endfor
#:endfor
end interface
interface arg_select
!! version: experimental
!! ([Specification](..//page/specs/stdlib_selection.html#arg_select-find-the-index-of-the-k-th-smallest-value-in-an-input-array))
#:for arraykind, arraytype in ARRAY_KINDS_TYPES
#:for intkind, inttype in INT_KINDS_TYPES
#:set name = rname("arg_select", 1, arraytype, arraykind, intkind)
module procedure ${name}$
#:endfor
#:endfor
end interface
contains
#:for arraykind, arraytype in ARRAY_KINDS_TYPES
#:for intkind, inttype in INT_KINDS_TYPES
#:set name = rname("select", 1, arraytype, arraykind, intkind)
subroutine ${name}$(a, k, kth_smallest, left, right)
!! select - select the k-th smallest entry in a(:).
!!
!! Partly derived from the "Coretran" implementation of
!! quickSelect by Leon Foks, https://github.com/leonfoks/coretran
!!
${arraytype}$, intent(inout) :: a(:)
!! Array in which we seek the k-th smallest entry.
!! On output it will be partially sorted such that
!! `all(a(1:(k-1)) <= a(k)) .and. all(a(k) <= a((k+1):size(a)))`
!! is true.
${inttype}$, intent(in) :: k
!! We want the k-th smallest entry. E.G. `k=1` leads to
!! `kth_smallest=min(a)`, and `k=size(a)` leads to
!! `kth_smallest=max(a)`
${arraytype}$, intent(out) :: kth_smallest
!! On output contains the k-th smallest value of `a(:)`
${inttype}$, intent(in), optional :: left, right
!! If we know that:
!! the k-th smallest entry of `a` is in `a(left:right)`
!! and also that:
!! `maxval(a(1:(left-1))) <= minval(a(left:right))`
!! and:
!! `maxval(a(left:right))) <= minval(a((right+1):size(a)))`
!! then one or both bounds can be specified to narrow the search.
!! The constraints are available if we have previously called the
!! subroutine with different `k` (because of how `a(:)` becomes
!! partially sorted, see documentation for `a(:)`).
${inttype}$ :: l, r, mid, iPivot
integer, parameter :: ip = ${intkind}$
l = 1_ip
if(present(left)) l = left
r = size(a, kind=ip)
if(present(right)) r = right
if(l > r .or. l < 1_ip .or. r > size(a, kind=ip) &
.or. k < l .or. k > r & !i.e. if k is not in the interval [l; r]
) then
error stop "select must have 1 <= left <= k <= right <= size(a)";
end if
searchk: do
mid = l + ((r-l)/2_ip) ! Avoid (l+r)/2 which can cause overflow
call medianOf3(a, l, mid, r)
call swap(a(l), a(mid))
call partition(a, l, r, iPivot)
if (iPivot < k) then
l = iPivot + 1_ip
elseif (iPivot > k) then
r = iPivot - 1_ip
elseif (iPivot == k) then
kth_smallest = a(k)
return
end if
end do searchk
contains
pure subroutine swap(a, b)
${arraytype}$, intent(inout) :: a, b
${arraytype}$ :: tmp
tmp = a; a = b; b = tmp
end subroutine
pure subroutine medianOf3(a, left, mid, right)
${arraytype}$, intent(inout) :: a(:)
${inttype}$, intent(in) :: left, mid, right
if(a(right) < a(left)) call swap(a(right), a(left))
if(a(mid) < a(left)) call swap(a(mid) , a(left))
if(a(right) < a(mid) ) call swap(a(mid) , a(right))
end subroutine
pure subroutine partition(array,left,right,iPivot)
${arraytype}$, intent(inout) :: array(:)
${inttype}$, intent(in) :: left, right
${inttype}$, intent(out) :: iPivot
${inttype}$ :: lo,hi
${arraytype}$ :: pivot
pivot = array(left)
lo = left
hi=right
do while (lo <= hi)
do while (array(hi) > pivot)
hi=hi-1_ip
end do
inner_lohi: do while (lo <= hi )
if(array(lo) > pivot) exit inner_lohi
lo=lo+1_ip
end do inner_lohi
if (lo <= hi) then
call swap(array(lo),array(hi))
lo=lo+1_ip
hi=hi-1_ip
end if
end do
call swap(array(left),array(hi))
iPivot=hi
end subroutine
end subroutine
#:endfor
#:endfor
#:for arraykind, arraytype in ARRAY_KINDS_TYPES
#:for intkind, inttype in INT_KINDS_TYPES
#:set name = rname("arg_select", 1, arraytype, arraykind, intkind)
subroutine ${name}$(a, indx, k, kth_smallest, left, right)
!! arg_select - find the index of the k-th smallest entry in `a(:)`
!!
!! Partly derived from the "Coretran" implementation of
!! quickSelect by Leon Foks, https://github.com/leonfoks/coretran
!!
${arraytype}$, intent(in) :: a(:)
!! Array in which we seek the k-th smallest entry.
${inttype}$, intent(inout) :: indx(:)
!! Array of indices into `a(:)`. Must contain each integer
!! from `1:size(a)` exactly once. On output it will be partially
!! sorted such that
!! `all( a(indx(1:(k-1)))) <= a(indx(k)) ) .AND.
!! all( a(indx(k)) <= a(indx( (k+1):size(a) )) )`.
${inttype}$, intent(in) :: k
!! We want index of the k-th smallest entry. E.G. `k=1` leads to
!! `a(kth_smallest) = min(a)`, and `k=size(a)` leads to
!! `a(kth_smallest) = max(a)`
${inttype}$, intent(out) :: kth_smallest
!! On output contains the index with the k-th smallest value of `a(:)`
${inttype}$, intent(in), optional :: left, right
!! If we know that:
!! the k-th smallest entry of `a` is in `a(indx(left:right))`
!! and also that:
!! `maxval(a(indx(1:(left-1)))) <= minval(a(indx(left:right)))`
!! and:
!! `maxval(a(indx(left:right))) <= minval(a(indx((right+1):size(a))))`
!! then one or both bounds can be specified to reduce the search
!! time. These constraints are available if we have previously
!! called the subroutine with a different `k` (due to the way that
!! `indx(:)` becomes partially sorted, see documentation for `indx(:)`).
${inttype}$ :: l, r, mid, iPivot
integer, parameter :: ip = ${intkind}$
l = 1_ip
if(present(left)) l = left
r = size(a, kind=ip)
if(present(right)) r = right
if(size(a) /= size(indx)) then
error stop "arg_select must have size(a) == size(indx)"
end if
if(l > r .or. l < 1_ip .or. r > size(a, kind=ip) &
.or. k < l .or. k > r & !i.e. if k is not in the interval [l; r]
) then
error stop "arg_select must have 1 <= left <= k <= right <= size(a)";
end if
searchk: do
mid = l + ((r-l)/2_ip) ! Avoid (l+r)/2 which can cause overflow
call arg_medianOf3(a, indx, l, mid, r)
call swap(indx(l), indx(mid))
call arg_partition(a, indx, l, r, iPivot)
if (iPivot < k) then
l = iPivot + 1_ip
elseif (iPivot > k) then
r = iPivot - 1_ip
elseif (iPivot == k) then
kth_smallest = indx(k)
return
end if
end do searchk
contains
pure subroutine swap(a, b)
${inttype}$, intent(inout) :: a, b
${inttype}$ :: tmp
tmp = a; a = b; b = tmp
end subroutine
pure subroutine arg_medianOf3(a, indx, left, mid, right)
${arraytype}$, intent(in) :: a(:)
${inttype}$, intent(inout) :: indx(:)
${inttype}$, intent(in) :: left, mid, right
if(a(indx(right)) < a(indx(left))) call swap(indx(right), indx(left))
if(a(indx(mid)) < a(indx(left))) call swap(indx(mid) , indx(left))
if(a(indx(right)) < a(indx(mid)) ) call swap(indx(mid) , indx(right))
end subroutine
pure subroutine arg_partition(array, indx, left,right,iPivot)
${arraytype}$, intent(in) :: array(:)
${inttype}$, intent(inout) :: indx(:)
${inttype}$, intent(in) :: left, right
${inttype}$, intent(out) :: iPivot
${inttype}$ :: lo,hi
${arraytype}$ :: pivot
pivot = array(indx(left))
lo = left
hi = right
do while (lo <= hi)
do while (array(indx(hi)) > pivot)
hi=hi-1_ip
end do
inner_lohi: do while (lo <= hi )
if(array(indx(lo)) > pivot) exit inner_lohi
lo=lo+1_ip
end do inner_lohi
if (lo <= hi) then
call swap(indx(lo),indx(hi))
lo=lo+1_ip
hi=hi-1_ip
end if
end do
call swap(indx(left),indx(hi))
iPivot=hi
end subroutine
end subroutine
#:endfor
#:endfor
end module
fortran-lang-stdlib-0ede301/src/specialmatrices/ 0000775 0001750 0001750 00000000000 15135654166 022125 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/specialmatrices/CMakeLists.txt 0000664 0001750 0001750 00000000777 15135654166 024700 0 ustar alastair alastair set(specialmatrices_fppFiles
stdlib_specialmatrices.fypp
stdlib_specialmatrices_tridiagonal.fypp
)
set(specialmatrices_cppFiles
)
set(specialmatrices_f90Files
)
configure_stdlib_target(${PROJECT_NAME}_specialmatrices specialmatrices_f90Files specialmatrices_fppFiles specialmatrices_cppFiles)
target_link_libraries(${PROJECT_NAME}_specialmatrices PUBLIC ${PROJECT_NAME}_constants ${PROJECT_NAME}_linalg_core ${PROJECT_NAME}_linalg ${PROJECT_NAME}_lapack ${PROJECT_NAME}_lapack_extended)
fortran-lang-stdlib-0ede301/src/specialmatrices/stdlib_specialmatrices.fypp 0000664 0001750 0001750 00000024667 15135654166 027555 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, 2+1)
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES
module stdlib_specialmatrices
!! Provides derived-types and associated specialized linear algebra drivers
!! for highly-structured matrices commonly encountered in the discretization
!! of partial differential equations, as well as control and signal processing
!! applications. ([Specifications](../page/specs/stdlib_specialmatrices.html))
use stdlib_linalg_constants
use stdlib_constants
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
use stdlib_lapack_extended_base
implicit none
private
public :: tridiagonal
public :: spmv
public :: dense, transpose, hermitian
public :: operator(*), operator(+), operator(-)
!--------------------------------------
!----- ------
!----- TYPE DEFINITIONS ------
!----- ------
!--------------------------------------
!--> Tridiagonal matrices
#:for k1, t1, s1 in (KINDS_TYPES)
type, public :: tridiagonal_${s1}$_type
!! Base type to define a `tridiagonal` matrix.
private
${t1}$, allocatable :: dl(:), dv(:), du(:)
integer(ilp) :: n
end type
#:endfor
!--------------------------------
!----- -----
!----- CONSTRUCTORS -----
!----- -----
!--------------------------------
interface tridiagonal
!! ([Specifications](../page/specs/stdlib_specialmatrices.html#Tridiagonal)) This
!! interface provides different methods to construct a `tridiagonal` matrix. Only
!! the non-zero elements of \( A \) are stored, i.e.
!!
!! \[
!! A
!! =
!! \begin{bmatrix}
!! a_1 & b_1 \\
!! c_1 & a_2 & b_2 \\
!! & \ddots & \ddots & \ddots \\
!! & & c_{n-2} & a_{n-1} & b_{n-1} \\
!! & & & c_{n-1} & a_n
!! \end{bmatrix}.
!! \]
!!
!! #### Syntax
!!
!! - Construct a real `tridiagonal` matrix from rank-1 arrays:
!!
!! ```fortran
!! integer, parameter :: n
!! real(dp), allocatable :: dl(:), dv(:), du(:)
!! type(tridiagonal_rdp_type) :: A
!! integer :: i
!!
!! dl = [(i, i=1, n-1)]; dv = [(2*i, i=1, n)]; du = [(3*i, i=1, n)]
!! A = Tridiagonal(dl, dv, du)
!! ```
!!
!! - Construct a real `tridiagonal` matrix with constant diagonals:
!!
!! ```fortran
!! integer, parameter :: n
!! real(dp), parameter :: a = 1.0_dp, b = 1.0_dp, c = 2.0_dp
!! type(tridiagonal_rdp_type) :: A
!!
!! A = Tridiagonal(a, b, c, n)
!! ```
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function initialize_tridiagonal_pure_${s1}$(dl, dv, du) result(A)
!! Construct a `tridiagonal` matrix from the rank-1 arrays
!! `dl`, `dv` and `du`.
${t1}$, intent(in) :: dl(:), dv(:), du(:)
!! Tridiagonal matrix elements.
type(tridiagonal_${s1}$_type) :: A
!! Corresponding Tridiagonal matrix.
end function
pure module function initialize_constant_tridiagonal_pure_${s1}$(dl, dv, du, n) result(A)
!! Construct a `tridiagonal` matrix with constant elements.
${t1}$, intent(in) :: dl, dv, du
!! Tridiagonal matrix elements.
integer(ilp), intent(in) :: n
!! Matrix dimension.
type(tridiagonal_${s1}$_type) :: A
!! Corresponding Tridiagonal matrix.
end function
module function initialize_tridiagonal_impure_${s1}$(dl, dv, du, err) result(A)
!! Construct a `tridiagonal` matrix from the rank-1 arrays
!! `dl`, `dv` and `du`.
${t1}$, intent(in) :: dl(:), dv(:), du(:)
!! Tridiagonal matrix elements.
type(linalg_state_type), intent(out) :: err
!! Error handling.
type(tridiagonal_${s1}$_type) :: A
!! Corresponding Tridiagonal matrix.
end function
module function initialize_constant_tridiagonal_impure_${s1}$(dl, dv, du, n, err) result(A)
!! Construct a `tridiagonal` matrix with constant elements.
${t1}$, intent(in) :: dl, dv, du
!! Tridiagonal matrix elements.
integer(ilp), intent(in) :: n
!! Matrix dimension.
type(linalg_state_type), intent(out) :: err
!! Error handling.
type(tridiagonal_${s1}$_type) :: A
!! Corresponding Tridiagonal matrix.
end function
#:endfor
end interface
!----------------------------------
!----- -----
!----- LINEAR ALGEBRA -----
!----- -----
!----------------------------------
interface spmv
!! ([Specifications](../page/specs/stdlib_specialmatrices.html#spmv)) This
!! interface provides methods to compute the matrix-vector product
!!
!! $$ y = \alpha \mathrm{op}(A) x + \beta y$$
!!
!! for the different matrix types defined by `stdlib_specialmatrices`.
#:for k1, t1, s1 in (KINDS_TYPES)
#:for rank in RANKS
module subroutine spmv_tridiag_${rank}$d_${s1}$(A, x, y, alpha, beta, op)
type(tridiagonal_${s1}$_type), intent(in) :: A
${t1}$, intent(in), contiguous, target :: x${ranksuffix(rank)}$
${t1}$, intent(inout), contiguous, target :: y${ranksuffix(rank)}$
${t1}$, intent(in), optional :: alpha
${t1}$, intent(in), optional :: beta
character(1), intent(in), optional :: op
end subroutine
#:endfor
#:endfor
end interface
!-------------------------------------
!----- -----
!----- UTILITY FUNCTIONS -----
!----- -----
!-------------------------------------
interface dense
!! This interface provides methods to convert a matrix of one of the
!! types defined by `stdlib_specialmatrices` to a standard rank-2 array.
!! ([Specifications](../page/specs/stdlib_specialmatrices.html#dense))
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function tridiagonal_to_dense_${s1}$(A) result(B)
!! Convert a `tridiagonal` matrix to its dense representation.
type(tridiagonal_${s1}$_type), intent(in) :: A
!! Input Tridiagonal matrix.
${t1}$, allocatable :: B(:, :)
!! Corresponding dense matrix.
end function
#:endfor
end interface
interface transpose
!! This interface provides methods to compute the transpose operation for
!! the different matrix types defined by `stdlib_specialmatrices`.
!! [Specifications](../page/specs/stdlib_specialmatrices.html#transpose)
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function transpose_tridiagonal_${s1}$(A) result(B)
type(tridiagonal_${s1}$_type), intent(in) :: A
!! Input matrix.
type(tridiagonal_${s1}$_type) :: B
end function
#:endfor
end interface
interface hermitian
!! This interface provides methods to compute the hermitian operation for
!! the different matrix types defined by `stdlib_specialmatrices`. For
!! real-valued matrices, this is equivalent to the standard `transpose`.
!! [Specifications](../page/specs/stdlib_specialmatrices.html#hermitian)
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function hermitian_tridiagonal_${s1}$(A) result(B)
type(tridiagonal_${s1}$_type), intent(in) :: A
!! Input matrix.
type(tridiagonal_${s1}$_type) :: B
end function
#:endfor
end interface
!----------------------------------------
!----- -----
!----- ARITHMETIC OPERATORS -----
!----- -----
!----------------------------------------
interface operator(*)
!! Overload the `*` for scalar-matrix multiplications for the different matrix
!! types provided by `stdlib_specialmatrices`.
!! [Specifications](../page/specs/stdlib_specialmatrices.html#operators)
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function scalar_multiplication_tridiagonal_${s1}$(alpha, A) result(B)
${t1}$, intent(in) :: alpha
type(tridiagonal_${s1}$_type), intent(in) :: A
type(tridiagonal_${s1}$_type) :: B
end function
pure module function scalar_multiplication_bis_tridiagonal_${s1}$(A, alpha) result(B)
type(tridiagonal_${s1}$_type), intent(in) :: A
${t1}$, intent(in) :: alpha
type(tridiagonal_${s1}$_type) :: B
end function
#:endfor
end interface
interface operator(+)
!! Overload the `+` operator for matrix-matrix addition. The two matrices need to
!! be of the same type and kind.
!! [Specifications](../page/specs/stdlib_specialmatrices.html#operators)
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function matrix_add_tridiagonal_${s1}$(A, B) result(C)
type(tridiagonal_${s1}$_type), intent(in) :: A
type(tridiagonal_${s1}$_type), intent(in) :: B
type(tridiagonal_${s1}$_type) :: C
end function
#:endfor
end interface
interface operator(-)
!! Overload the `-` operator for matrix-matrix subtraction. The two matrices need to
!! be of the same type and kind.
!! [Specifications](../page/specs/stdlib_specialmatrices.html#operators)
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function matrix_sub_tridiagonal_${s1}$(A, B) result(C)
type(tridiagonal_${s1}$_type), intent(in) :: A
type(tridiagonal_${s1}$_type), intent(in) :: B
type(tridiagonal_${s1}$_type) :: C
end function
#:endfor
end interface
end module stdlib_specialmatrices
fortran-lang-stdlib-0ede301/src/specialmatrices/stdlib_specialmatrices_tridiagonal.fypp 0000664 0001750 0001750 00000026243 15135654166 032122 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, 2+1)
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES
submodule (stdlib_specialmatrices) tridiagonal_matrices
use stdlib_linalg_lapack, only: lagtm
character(len=*), parameter :: this = "tridiagonal matrices"
contains
!--------------------------------
!----- -----
!----- CONSTRUCTORS -----
!----- -----
!--------------------------------
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function initialize_tridiagonal_pure_${s1}$(dl, dv, du) result(A)
!! Construct a `tridiagonal` matrix from the rank-1 arrays
!! `dl`, `dv` and `du`.
${t1}$, intent(in) :: dl(:), dv(:), du(:)
!! tridiagonal matrix elements.
type(tridiagonal_${s1}$_type) :: A
!! Corresponding tridiagonal matrix.
! Internal variables.
integer(ilp) :: n
type(linalg_state_type) :: err0
! Sanity check.
n = size(dv, kind=ilp)
if (n <= 0) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, "Matrix size needs to be positive, n = ", n, ".")
call linalg_error_handling(err0)
endif
if (size(dl, kind=ilp) /= n-1) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, "Vector dl does not have the correct length.")
call linalg_error_handling(err0)
endif
if (size(du, kind=ilp) /= n-1) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, "Vector du does not have the correct length.")
call linalg_error_handling(err0)
endif
! Description of the matrix.
A%n = n
! Matrix elements.
A%dl = dl ; A%dv = dv ; A%du = du
end function
pure module function initialize_constant_tridiagonal_pure_${s1}$(dl, dv, du, n) result(A)
!! Construct a `tridiagonal` matrix with constant elements.
${t1}$, intent(in) :: dl, dv, du
!! tridiagonal matrix elements.
integer(ilp), intent(in) :: n
!! Matrix dimension.
type(tridiagonal_${s1}$_type) :: A
!! Corresponding tridiagonal matrix.
! Internal variables.
integer(ilp) :: i
type(linalg_state_type) :: err0
! Description of the matrix.
A%n = n
if (n <= 0) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, "Matrix size needs to be positive, n = ", n, ".")
call linalg_error_handling(err0)
endif
! Matrix elements.
allocate( A%dl(n-1), source = dl )
allocate( A%dv(n), source= dv )
allocate( A%du(n-1), source = du )
end function
module function initialize_tridiagonal_impure_${s1}$(dl, dv, du, err) result(A)
!! Construct a `tridiagonal` matrix from the rank-1 arrays
!! `dl`, `dv` and `du`.
${t1}$, intent(in) :: dl(:), dv(:), du(:)
!! tridiagonal matrix elements.
type(linalg_state_type), intent(out) :: err
!! Error handling.
type(tridiagonal_${s1}$_type) :: A
!! Corresponding tridiagonal matrix.
! Internal variables.
integer(ilp) :: n
type(linalg_state_type) :: err0
! Sanity check.
n = size(dv, kind=ilp)
if (n <= 0) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, "Matrix size needs to be positive, n = ", n, ".")
call linalg_error_handling(err0, err)
endif
if (size(dl, kind=ilp) /= n-1) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, "Vector dl does not have the correct length.")
call linalg_error_handling(err0, err)
endif
if (size(du, kind=ilp) /= n-1) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, "Vector du does not have the correct length.")
call linalg_error_handling(err0, err)
endif
if(err0%ok()) then
! Description of the matrix.
A%n = n
! Matrix elements.
A%dl = dl ; A%dv = dv ; A%du = du
endif
end function
module function initialize_constant_tridiagonal_impure_${s1}$(dl, dv, du, n, err) result(A)
!! Construct a `tridiagonal` matrix with constant elements.
${t1}$, intent(in) :: dl, dv, du
!! tridiagonal matrix elements.
integer(ilp), intent(in) :: n
!! Matrix dimension.
type(linalg_state_type), intent(out) :: err
!! Error handling
type(tridiagonal_${s1}$_type) :: A
!! Corresponding tridiagonal matrix.
! Internal variables.
integer(ilp) :: i
type(linalg_state_type) :: err0
if (n <= 0) then
err0 = linalg_state_type(this, LINALG_VALUE_ERROR, "Matrix size needs to be positive, n = ", n, ".")
call linalg_error_handling(err0, err)
endif
if(err0%ok()) then
! Description of the matrix.
A%n = n
! Matrix elements.
allocate( A%dl(n-1), source = dl )
allocate( A%dv(n), source= dv )
allocate( A%du(n-1), source = du )
endif
end function
#:endfor
!-----------------------------------------
!----- -----
!----- MATRIX-VECTOR PRODUCT -----
!----- -----
!-----------------------------------------
!! spmv_tridiag
#:for k1, t1, s1 in (KINDS_TYPES)
#:for rank in RANKS
module subroutine spmv_tridiag_${rank}$d_${s1}$(A, x, y, alpha, beta, op)
type(tridiagonal_${s1}$_type), intent(in) :: A
${t1}$, intent(in), contiguous, target :: x${ranksuffix(rank)}$
${t1}$, intent(inout), contiguous, target :: y${ranksuffix(rank)}$
${t1}$, intent(in), optional :: alpha
${t1}$, intent(in), optional :: beta
character(1), intent(in), optional :: op
! Internal variables.
${t1}$ :: alpha_, beta_
integer(ilp) :: n, nrhs, ldx, ldy
character(1) :: op_
#:if t1.startswith('real')
logical :: is_alpha_special, is_beta_special
#:endif
#:if rank == 1
${t1}$, pointer :: xmat(:, :), ymat(:, :)
#:endif
! Deal with optional arguments.
alpha_ = 1.0_${k1}$ ; if (present(alpha)) alpha_ = alpha
beta_ = 0.0_${k1}$ ; if (present(beta)) beta_ = beta
op_ = "N" ; if (present(op)) op_ = op
#:if t1.startswith('real')
is_alpha_special = (alpha_ == 1.0_${k1}$ .or. alpha_ == 0.0_${k1}$ .or. alpha_ == -1.0_${k1}$)
is_beta_special = (beta_ == 1.0_${k1}$ .or. beta_ == 0.0_${k1}$ .or. beta_ == -1.0_${k1}$)
#:endif
! Prepare Lapack arguments.
n = A%n ; ldx = n ; ldy = n ;
nrhs = #{if rank==1}# 1 #{else}# size(x, dim=2, kind=ilp) #{endif}#
#:if rank == 1
! Pointer trick.
xmat(1:n, 1:nrhs) => x ; ymat(1:n, 1:nrhs) => y
#:if t1.startswith('complex')
call glagtm(op_, n, nrhs, alpha_, A%dl, A%dv, A%du, xmat, ldx, beta_, ymat, ldy)
#:else
if(is_alpha_special .and. is_beta_special) then
call lagtm(op_, n, nrhs, alpha_, A%dl, A%dv, A%du, xmat, ldx, beta_, ymat, ldy)
else
call glagtm(op_, n, nrhs, alpha_, A%dl, A%dv, A%du, xmat, ldx, beta_, ymat, ldy)
end if
#:endif
#:else
#:if t1.startswith('complex')
call glagtm(op_, n, nrhs, alpha_, A%dl, A%dv, A%du, x, ldx, beta_, y, ldy)
#:else
if(is_alpha_special .and. is_beta_special) then
call lagtm(op_, n, nrhs, alpha_, A%dl, A%dv, A%du, x, ldx, beta_, y, ldy)
else
call glagtm(op_, n, nrhs, alpha_, A%dl, A%dv, A%du, x, ldx, beta_, y, ldy)
end if
#:endif
#:endif
end subroutine
#:endfor
#:endfor
!-------------------------------------
!----- -----
!----- UTILITY FUNCTIONS -----
!----- -----
!-------------------------------------
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function tridiagonal_to_dense_${s1}$(A) result(B)
!! Convert a `tridiagonal` matrix to its dense representation.
type(tridiagonal_${s1}$_type), intent(in) :: A
!! Input tridiagonal matrix.
${t1}$, allocatable :: B(:, :)
!! Corresponding dense matrix.
! Internal variables.
integer(ilp) :: i
associate (n => A%n)
#:if t1.startswith('complex')
allocate(B(n, n), source=zero_c${k1}$)
#:else
allocate(B(n, n), source=zero_${k1}$)
#:endif
B(1, 1) = A%dv(1) ; B(1, 2) = A%du(1)
do concurrent (i=2:n-1)
B(i, i-1) = A%dl(i-1)
B(i, i) = A%dv(i)
B(i, i+1) = A%du(i)
enddo
B(n, n-1) = A%dl(n-1) ; B(n, n) = A%dv(n)
end associate
end function
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function transpose_tridiagonal_${s1}$(A) result(B)
type(tridiagonal_${s1}$_type), intent(in) :: A
!! Input matrix.
type(tridiagonal_${s1}$_type) :: B
B = tridiagonal(A%du, A%dv, A%dl)
end function
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function hermitian_tridiagonal_${s1}$(A) result(B)
type(tridiagonal_${s1}$_type), intent(in) :: A
!! Input matrix.
type(tridiagonal_${s1}$_type) :: B
#:if t1.startswith("complex")
B = tridiagonal(conjg(A%du), conjg(A%dv), conjg(A%dl))
#:else
B = tridiagonal(A%du, A%dv, A%dl)
#:endif
end function
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function scalar_multiplication_tridiagonal_${s1}$(alpha, A) result(B)
${t1}$, intent(in) :: alpha
type(tridiagonal_${s1}$_type), intent(in) :: A
type(tridiagonal_${s1}$_type) :: B
B = tridiagonal(A%dl, A%dv, A%du)
B%dl = alpha*B%dl; B%dv = alpha*B%dv; B%du = alpha*B%du
end function
pure module function scalar_multiplication_bis_tridiagonal_${s1}$(A, alpha) result(B)
type(tridiagonal_${s1}$_type), intent(in) :: A
${t1}$, intent(in) :: alpha
type(tridiagonal_${s1}$_type) :: B
B = tridiagonal(A%dl, A%dv, A%du)
B%dl = alpha*B%dl; B%dv = alpha*B%dv; B%du = alpha*B%du
end function
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
pure module function matrix_add_tridiagonal_${s1}$(A, B) result(C)
type(tridiagonal_${s1}$_type), intent(in) :: A
type(tridiagonal_${s1}$_type), intent(in) :: B
type(tridiagonal_${s1}$_type) :: C
C = tridiagonal(A%dl, A%dv, A%du)
C%dl = C%dl + B%dl; C%dv = C%dv + B%dv; C%du = C%du + B%du
end function
pure module function matrix_sub_tridiagonal_${s1}$(A, B) result(C)
type(tridiagonal_${s1}$_type), intent(in) :: A
type(tridiagonal_${s1}$_type), intent(in) :: B
type(tridiagonal_${s1}$_type) :: C
C = tridiagonal(A%dl, A%dv, A%du)
C%dl = C%dl - B%dl; C%dv = C%dv - B%dv; C%du = C%du - B%du
end function
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/math/ 0000775 0001750 0001750 00000000000 15135654166 017706 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/math/stdlib_math_logspace.fypp 0000664 0001750 0001750 00000006312 15135654166 024757 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_math) stdlib_math_logspace
implicit none
contains
#!=========================================================
#!= logspace(start, end) =
#!=========================================================
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("logspace", 1, t1, k1, "default")
module procedure ${RName}$
res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, real(DEFAULT_LOGSPACE_BASE, ${k1}$))
end procedure
#:endfor
#! Integer support
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "default")
module procedure ${RName}$
res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, DEFAULT_LOGSPACE_BASE)
end procedure
#!=========================================================
#!= logspace(start, end, n) =
#!=========================================================
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("logspace", 1, t1, k1, "n")
module procedure ${RName}$
res = logspace(start, end, n, real(DEFAULT_LOGSPACE_BASE, ${k1}$))
end procedure
#:endfor
#! Integer support
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "n")
module procedure ${RName}$
res = logspace(start, end, n, DEFAULT_LOGSPACE_BASE)
end procedure
#!=========================================================
#!= logspace(start, end, n, base) =
#!=========================================================
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("logspace", 1, t1, k1, "n_rbase")
module procedure ${RName}$
${t1}$ :: exponents(max(n, 0))
exponents = linspace(start, end, n)
res = base ** exponents
end procedure
#:set RName = rname("logspace", 1, t1, k1, "n_cbase")
module procedure ${RName}$
${t1}$ :: exponents(max(n, 0))
exponents = linspace(start, end, n)
res = base ** exponents
end procedure
#:set RName = rname("logspace", 1, t1, k1, "n_ibase")
module procedure ${RName}$
${t1}$ :: exponents(max(n, 0))
exponents = linspace(start, end, n)
res = base ** exponents
end procedure
#:endfor
#! Integer support:
! Generate logarithmically spaced sequence from ${k1}$ base to the powers
! of ${k1}$ start and end. [base^start, ... , base^end]
! RName = ${RName}$
#:for k1 in REAL_KINDS
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "n_r" + str(k1) + "base")
module procedure ${RName}$
integer :: exponents(max(n, 0))
exponents = linspace(start, end, n)
res = base ** exponents
end procedure
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "n_c" + str(k1) + "base")
module procedure ${RName}$
integer :: exponents(max(n, 0))
exponents = linspace(start, end, n)
res = base ** exponents
end procedure
#:endfor
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "n_ibase")
module procedure ${RName}$
integer :: exponents(max(n, 0))
exponents = linspace(start, end, n)
res = base ** exponents
end procedure
end submodule
fortran-lang-stdlib-0ede301/src/math/stdlib_math_all_close.fypp 0000664 0001750 0001750 00000001342 15135654166 025115 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_math) stdlib_math_all_close
implicit none
contains
#:for k1, t1 in RC_KINDS_TYPES
#:for r1 in RANKS
logical pure module function all_close_${r1}$_${t1[0]}$${k1}$(a, b, rel_tol, abs_tol, equal_nan) result(close)
${t1}$, intent(in) :: a${ranksuffix(r1)}$, b${ranksuffix(r1)}$
real(${k1}$), intent(in), optional :: rel_tol, abs_tol
logical, intent(in), optional :: equal_nan
close = all(is_close(a, b, rel_tol, abs_tol, equal_nan))
end function all_close_${r1}$_${t1[0]}$${k1}$
#:endfor
#:endfor
end submodule stdlib_math_all_close fortran-lang-stdlib-0ede301/src/math/stdlib_math_arange.fypp 0000664 0001750 0001750 00000003316 15135654166 024420 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_math) stdlib_math_arange
contains
#:for k1, t1 in REAL_KINDS_TYPES
!> `arange` creates a vector of the `${t1}$` type
!> with evenly spaced values within a given interval.
pure module function arange_${t1[0]}$_${k1}$(start, end, step) result(result)
${t1}$, intent(in) :: start
${t1}$, intent(in), optional :: end, step
${t1}$, allocatable :: result(:)
${t1}$ :: start_, end_, step_
integer :: i
start_ = merge(start, 1.0_${k1}$, present(end))
end_ = optval(end, start)
step_ = optval(step, 1.0_${k1}$)
step_ = sign(merge(step_, 1.0_${k1}$, step_ /= 0.0_${k1}$), end_ - start_)
allocate(result(floor((end_ - start_)/step_) + 1))
result = [(start_ + (i - 1)*step_, i=1, size(result), 1)]
end function arange_${t1[0]}$_${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
!> `arange` creates a vector of the `${t1}$` type
!> with evenly spaced values within a given interval.
pure module function arange_${t1[0]}$_${k1}$(start, end, step) result(result)
${t1}$, intent(in) :: start
${t1}$, intent(in), optional :: end, step
${t1}$, allocatable :: result(:)
${t1}$ :: start_, end_, step_
${t1}$ :: i
start_ = merge(start, 1_${k1}$, present(end))
end_ = optval(end, start)
step_ = optval(step, 1_${k1}$)
step_ = sign(merge(step_, 1_${k1}$, step_ /= 0_${k1}$), end_ - start_)
allocate(result((end_ - start_)/step_ + 1_${k1}$))
result = [(i, i=start_, end_, step_)]
end function arange_${t1[0]}$_${k1}$
#:endfor
end submodule stdlib_math_arange
fortran-lang-stdlib-0ede301/src/math/stdlib_math_linspace.fypp 0000664 0001750 0001750 00000004637 15135654166 024770 0 ustar alastair alastair #:include "common.fypp"
submodule (stdlib_math) stdlib_math_linspace
implicit none
contains
#:for k1, t1 in REAL_KINDS_TYPES
#:set RName = rname("linspace_default", 1, t1, k1)
pure module function ${RName}$(start, end) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
${t1}$ :: res(DEFAULT_LINSPACE_LENGTH)
res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)
end function ${RName}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
#:set RName = rname("linspace_n", 1, t1, k1)
pure module function ${RName}$(start, end, n) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
${t1}$ :: res(max(n, 0))
integer :: i ! Looping index
${t1}$ :: interval ! Difference between adjacent elements
if(n <= 0) return ! If passed length is less than or equal to 0, return an empty (allocated with length 0) array
if(n == 1) then
res(1) = end
return
end if
interval = (end - start) / real((n - 1), ${k1}$)
res(1) = start
res(n) = end
do i = 2, n - 1
res(i) = real((i-1), ${k1}$) * interval + start
end do
end function ${RName}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
#:set RName = rname("linspace_default", 1, t1, k1)
module procedure ${RName}$
res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)
end procedure ${RName}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
#:set RName = rname("linspace_n", 1, t1, k1)
module procedure ${RName}$
real(${k1}$) :: x(max(n, 0)) ! array of the real part of complex number
real(${k1}$) :: y(max(n, 0)) ! array of the imaginary part of the complex number
x = linspace(start%re, end%re, n)
y = linspace(start%im, end%im, n)
res = cmplx(x, y, kind=${k1}$)
end procedure ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("linspace_default", 1, t1, k1)
module procedure ${RName}$
res = linspace(real(start, kind=dp), real(end, kind=dp), DEFAULT_LINSPACE_LENGTH)
end procedure ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("linspace_n", 1, t1, k1)
module procedure ${RName}$
res = linspace(real(start, kind=dp), real(end, kind=dp), n)
end procedure ${RName}$
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/math/CMakeLists.txt 0000664 0001750 0001750 00000001053 15135654166 022445 0 ustar alastair alastair set(math_fppFiles
stdlib_math_all_close.fypp
stdlib_math_arange.fypp
stdlib_math_diff.fypp
stdlib_math_is_close.fypp
stdlib_math_linspace.fypp
stdlib_math_logspace.fypp
stdlib_math_meshgrid.fypp
)
set(math_cppFiles
stdlib_math.fypp
)
configure_stdlib_target(${PROJECT_NAME}_math "" math_fppFiles math_cppFiles)
if(STDLIB_BITSETS)
target_link_libraries(${PROJECT_NAME}_math PUBLIC ${PROJECT_NAME}_bitsets)
endif()
target_link_libraries(${PROJECT_NAME}_math PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_strings)
fortran-lang-stdlib-0ede301/src/math/stdlib_math_is_close.fypp 0000664 0001750 0001750 00000003204 15135654166 024757 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_math) stdlib_math_is_close
use, intrinsic :: ieee_arithmetic, only: ieee_is_nan
implicit none
#:for k1 in REAL_KINDS
real(${k1}$), parameter :: sqrt_eps_${k1}$ = sqrt(epsilon(1.0_${k1}$))
#:endfor
contains
#! Determines whether the values of `a` and `b` are close.
#:for k1, t1 in REAL_KINDS_TYPES
elemental module logical function is_close_${t1[0]}$${k1}$(a, b, rel_tol, abs_tol, equal_nan) result(close)
${t1}$, intent(in) :: a, b
real(${k1}$), intent(in), optional :: rel_tol, abs_tol
logical, intent(in), optional :: equal_nan
logical :: equal_nan_
equal_nan_ = optval(equal_nan, .false.)
if (ieee_is_nan(a) .or. ieee_is_nan(b)) then
close = equal_nan_ .and. ieee_is_nan(a) .and. ieee_is_nan(b)
else
close = abs(a - b) <= max( abs(optval(rel_tol, sqrt_eps_${k1}$)*max(abs(a), abs(b))), &
abs(optval(abs_tol, 0.0_${k1}$)) )
end if
end function is_close_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental module logical function is_close_${t1[0]}$${k1}$(a, b, rel_tol, abs_tol, equal_nan) result(close)
${t1}$, intent(in) :: a, b
real(${k1}$), intent(in), optional :: rel_tol, abs_tol
logical, intent(in), optional :: equal_nan
close = is_close_r${k1}$(a%re, b%re, rel_tol, abs_tol, equal_nan) .and. &
is_close_r${k1}$(a%im, b%im, rel_tol, abs_tol, equal_nan)
end function is_close_${t1[0]}$${k1}$
#:endfor
end submodule stdlib_math_is_close
fortran-lang-stdlib-0ede301/src/math/stdlib_math_meshgrid.fypp 0000664 0001750 0001750 00000002421 15135654166 024761 0 ustar alastair alastair #:include "common.fypp"
#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES
#:set RANKS = range(1, MAXRANK + 1)
#:def meshgrid_loop(indices)
#:for j in reversed(indices)
do i${j}$ = 1, size(x${j}$)
#:endfor
#:for j in indices
xm${j}$(${",".join(f"i{j}" for j in indices)}$) = &
x${j}$(i${j}$)
#:endfor
#:for j in indices
end do
#:endfor
#:enddef
submodule(stdlib_math) stdlib_math_meshgrid
use stdlib_error, only: error_stop
contains
#:for k1, t1 in IR_KINDS_TYPES
#:for rank in RANKS
#:if rank == 1
#:set XY_INDICES = [1]
#:set IJ_INDICES = [1]
#:else
#:set XY_INDICES = [2, 1] + [j for j in range(3, rank + 1)]
#:set IJ_INDICES = [1, 2] + [j for j in range(3, rank + 1)]
#:endif
#: set RName = rname("meshgrid", rank, t1, k1)
module procedure ${RName}$
integer :: ${",".join(f"i{j}" for j in range(1, rank + 1))}$
select case (optval(indexing, stdlib_meshgrid_xy))
case (stdlib_meshgrid_xy)
$:meshgrid_loop(XY_INDICES)
case (stdlib_meshgrid_ij)
$:meshgrid_loop(IJ_INDICES)
case default
call error_stop("ERROR (meshgrid): unexpected indexing.")
end select
end procedure
#:endfor
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/math/stdlib_math.fypp 0000664 0001750 0001750 00000051103 15135654166 023100 0 ustar alastair alastair #include "macros.inc"
#:include "common.fypp"
#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
module stdlib_math
use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
use stdlib_optval, only: optval
#if STDLIB_BITSETS
use stdlib_bitsets, only: bitset_64, bitset_large
#endif
implicit none
private
public :: clip, swap, gcd, linspace, logspace
public :: EULERS_NUMBER_SP, EULERS_NUMBER_DP
#:if WITH_QP
public :: EULERS_NUMBER_QP
#:endif
public :: DEFAULT_LINSPACE_LENGTH, DEFAULT_LOGSPACE_BASE, DEFAULT_LOGSPACE_LENGTH
public :: stdlib_meshgrid_ij, stdlib_meshgrid_xy
public :: arange, arg, argd, argpi, deg2rad, rad2deg, is_close, all_close, diff, meshgrid
integer, parameter :: DEFAULT_LINSPACE_LENGTH = 100
integer, parameter :: DEFAULT_LOGSPACE_LENGTH = 50
integer, parameter :: DEFAULT_LOGSPACE_BASE = 10
! Useful constants for lnspace
real(sp), parameter :: EULERS_NUMBER_SP = exp(1.0_sp)
real(dp), parameter :: EULERS_NUMBER_DP = exp(1.0_dp)
#:if WITH_QP
real(qp), parameter :: EULERS_NUMBER_QP = exp(1.0_qp)
#:endif
!> Useful constants `PI` for `argd/argpi`
#:for k1 in REAL_KINDS
real(kind=${k1}$), parameter :: PI_${k1}$ = acos(-1.0_${k1}$)
#:endfor
!> Values for optional argument `indexing` of `meshgrid`
integer, parameter :: stdlib_meshgrid_xy = 0, stdlib_meshgrid_ij = 1
interface clip
#:for k1, t1 in IR_KINDS_TYPES
module procedure clip_${k1}$
#:endfor
end interface clip
!> Swap the values of the lhs and rhs arguments
!> ([Specification](../page/specs/stdlib_math.html#swap_subroutine))
!>
!> Version: experimental
interface swap
#:for k1, t1, a1, cpp1 in INT_KINDS_TYPES + REAL_KINDS_TYPES + BITSETS_KINDS_TYPES
#:block generate_cpp(cpp_var=cpp1)
module procedure :: swap_${k1}$
#:endblock
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
module procedure :: swap_c${k1}$
#:endfor
module procedure :: swap_bool
module procedure :: swap_str
module procedure :: swap_stt
end interface
!> Returns the greatest common divisor of two integers
!> ([Specification](../page/specs/stdlib_math.html#gcd))
!>
!> Version: experimental
interface gcd
#:for k1, t1 in INT_KINDS_TYPES
module procedure gcd_${k1}$
#:endfor
end interface gcd
interface linspace
!! Version: Experimental
!!
!! Create rank 1 array of linearly spaced elements
!! If the number of elements is not specified, create an array with size 100. If n is a negative value,
!! return an array with size 0. If n = 1, return an array whose only element is end
!!([Specification](../page/specs/stdlib_math.html#linspace-create-a-linearly-spaced-rank-one-array))
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("linspace_default", 1, t1, k1)
pure module function ${RName}$(start, end) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
${t1}$ :: res(DEFAULT_LINSPACE_LENGTH)
end function ${RName}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("linspace_n", 1, t1, k1)
pure module function ${RName}$(start, end, n) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
${t1}$ :: res(max(n, 0))
end function ${RName}$
#:endfor
! Add support for integer linspace
!!
!! When dealing with integers as the `start` and `end` parameters, the return type is always a `real(dp)`.
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("linspace_default", 1, t1, k1)
#! The interface for INT_KINDS_TYPES cannot be combined with RC_KINDS_TYPES
#! because the output for integer types is always a real with dp.
pure module function ${RName}$(start, end) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
real(dp) :: res(DEFAULT_LINSPACE_LENGTH)
end function ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("linspace_n", 1, t1, k1)
pure module function ${RName}$(start, end, n) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
real(dp) :: res(max(n, 0))
end function ${RName}$
#:endfor
end interface
interface logspace
!! Version: Experimental
!!
!! Create rank 1 array of logarithmically spaced elements from base**start to base**end.
!! If the number of elements is not specified, create an array with size 50. If n is a negative value,
!! return an array with size 0. If n = 1, return an array whose only element is base**end. If no base
!! is specified, logspace will default to using a base of 10
!!
!!([Specification](../page/specs/stdlib_math.html#logspace-create-a-logarithmically-spaced-rank-one-array))
#!=========================================================
#!= logspace(start, end) =
#!=========================================================
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("logspace", 1, t1, k1, "default")
pure module function ${RName}$(start, end) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
${t1}$ :: res(DEFAULT_LOGSPACE_LENGTH)
end function ${RName}$
#:endfor
#! Integer support
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "default")
pure module function ${RName}$(start, end) result(res)
integer, intent(in) :: start
integer, intent(in) :: end
real(dp) :: res(DEFAULT_LOGSPACE_LENGTH)
end function ${RName}$
#!=========================================================
#!= logspace(start, end, n) =
#!=========================================================
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("logspace", 1, t1, k1, "n")
pure module function ${RName}$(start, end, n) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
${t1}$ :: res(max(n, 0))
end function ${RName}$
#:endfor
#! Integer support
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "n")
pure module function ${RName}$(start, end, n) result(res)
integer, intent(in) :: start
integer, intent(in) :: end
integer, intent(in) :: n
real(dp) :: res(n)
end function ${RName}$
#!=========================================================
#!= logspace(start, end, n, base) =
#!=========================================================
#! Need another function where base is not optional,
#! otherwise the compiler can not differentiate between
#! generic calls to logspace_n where a base is not present
#! ========================================================
#:for k1, t1 in REAL_KINDS_TYPES
! Generate logarithmically spaced sequence from ${k1}$ base to the powers
! of ${k1}$ start and end. [base^start, ... , base^end]
! Different combinations of parameter types will lead to different result types.
! Those combinations are indicated in the body of each function.
#:set RName = rname("logspace", 1, t1, k1, "n_rbase")
pure module function ${RName}$(start, end, n, base) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
${t1}$, intent(in) :: base
! real(${k1}$) endpoints + real(${k1}$) base = real(${k1}$) result
${t1}$ :: res(max(n, 0))
end function ${RName}$
#:set RName = rname("logspace", 1, t1, k1, "n_cbase")
pure module function ${RName}$(start, end, n, base) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
complex(${k1}$), intent(in) :: base
! real(${k1}$) endpoints + complex(${k1}$) base = complex(${k1}$) result
${t1}$ :: res(max(n, 0))
end function ${RName}$
#:set RName = rname("logspace", 1, t1, k1, "n_ibase")
pure module function ${RName}$(start, end, n, base) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
integer, intent(in) :: base
! real(${k1}$) endpoints + integer base = real(${k1}$) result
${t1}$ :: res(max(n, 0))
end function ${RName}$
#:endfor
#! ========================================================
#! ========================================================
#:for k1, t1 in CMPLX_KINDS_TYPES
! Generate logarithmically spaced sequence from ${k1}$ base to the powers
! of ${k1}$ start and end. [base^start, ... , base^end]
! Different combinations of parameter types will lead to different result types.
! Those combinations are indicated in the body of each function.
#:set RName = rname("logspace", 1, t1, k1, "n_rbase")
pure module function ${RName}$(start, end, n, base) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
real(${k1}$), intent(in) :: base
! complex(${k1}$) endpoints + real(${k1}$) base = complex(${k1}$) result
${t1}$ :: res(max(n, 0))
end function ${RName}$
#:set RName = rname("logspace", 1, t1, k1, "n_cbase")
pure module function ${RName}$(start, end, n, base) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
complex(${k1}$), intent(in) :: base
! complex(${k1}$) endpoints + complex(${k1}$) base = complex(${k1}$) result
${t1}$ :: res(max(n, 0))
end function ${RName}$
#:set RName = rname("logspace", 1, t1, k1, "n_ibase")
pure module function ${RName}$(start, end, n, base) result(res)
${t1}$, intent(in) :: start
${t1}$, intent(in) :: end
integer, intent(in) :: n
integer, intent(in) :: base
! complex(${k1}$) endpoints + integer base = complex(${k1}$) result
${t1}$ :: res(max(n, 0))
end function ${RName}$
#:endfor
#! ========================================================
#! ========================================================
#! Provide support for Integer start/endpoints
! Generate logarithmically spaced sequence from ${k1}$ base to the powers
! of ${k1}$ start and end. [base^start, ... , base^end]
! Different combinations of parameter types will lead to different result types.
! Those combinations are indicated in the body of each function.
#:for k1 in REAL_KINDS
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "n_r" + str(k1) + "base")
pure module function ${RName}$(start, end, n, base) result(res)
integer, intent(in) :: start
integer, intent(in) :: end
integer, intent(in) :: n
real(${k1}$), intent(in) :: base
! integer endpoints + real(${k1}$) base = real(${k1}$) result
real(${k1}$) :: res(max(n, 0))
end function ${RName}$
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "n_c" + str(k1) + "base")
pure module function ${RName}$(start, end, n, base) result(res)
integer, intent(in) :: start
integer, intent(in) :: end
integer, intent(in) :: n
complex(${k1}$), intent(in) :: base
! integer endpoints + complex(${k1}$) base = complex(${k1}$) result
complex(${k1}$) :: res(max(n, 0))
end function ${RName}$
#:endfor
#:set RName = rname("logspace", 1, "integer(int32)", "int32", "n_ibase")
pure module function ${RName}$(start, end, n, base) result(res)
integer, intent(in) :: start
integer, intent(in) :: end
integer, intent(in) :: n
integer, intent(in) :: base
! integer endpoints + integer base = integer result
integer :: res(max(n, 0))
end function ${RName}$
end interface
!> Version: experimental
!>
!> `arange` creates a one-dimensional `array` of the `integer/real` type
!> with fixed-spaced values of given spacing, within a given interval.
!> ([Specification](../page/specs/stdlib_math.html#arange-function))
interface arange
#:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES
#:for k1, t1 in RI_KINDS_TYPES
pure module function arange_${t1[0]}$_${k1}$(start, end, step) result(result)
${t1}$, intent(in) :: start
${t1}$, intent(in), optional :: end, step
${t1}$, allocatable :: result(:)
end function arange_${t1[0]}$_${k1}$
#:endfor
end interface arange
!> Version: experimental
!>
!> `arg` computes the phase angle in the interval (-π,π].
!> ([Specification](../page/specs/stdlib_math.html#arg-function))
interface arg
#:for k1 in CMPLX_KINDS
procedure :: arg_${k1}$
#:endfor
end interface arg
!> Version: experimental
!>
!> `argd` computes the phase angle of degree version in the interval (-180.0,180.0].
!> ([Specification](../page/specs/stdlib_math.html#argd-function))
interface argd
#:for k1 in CMPLX_KINDS
procedure :: argd_${k1}$
#:endfor
end interface argd
!> Version: experimental
!>
!> `argpi` computes the phase angle of circular version in the interval (-1.0,1.0].
!> ([Specification](../page/specs/stdlib_math.html#argpi-function))
interface argpi
#:for k1 in CMPLX_KINDS
procedure :: argpi_${k1}$
#:endfor
end interface argpi
!> Version: experimental
!>
!> `deg2rad` converts phase angles from degrees to radians.
!> ([Specification](../page/specs/stdlib_math.html#deg2rad-function))
interface deg2rad
#:for k1 in REAL_KINDS
procedure :: deg2rad_${k1}$
#:endfor
end interface deg2rad
!> Version: experimental
!>
!> `rad2deg` converts phase angles from radians to degrees.
!> ([Specification](../page/specs/stdlib_math.html#rad2deg-function))
interface rad2deg
#:for k1 in REAL_KINDS
procedure :: rad2deg_${k1}$
#:endfor
end interface rad2deg
!> Returns a boolean scalar/array where two scalar/arrays are element-wise equal within a tolerance.
!> ([Specification](../page/specs/stdlib_math.html#is_close-function))
interface is_close
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#:for k1, t1 in RC_KINDS_TYPES
elemental module logical function is_close_${t1[0]}$${k1}$(a, b, rel_tol, abs_tol, equal_nan) result(close)
${t1}$, intent(in) :: a, b
real(${k1}$), intent(in), optional :: rel_tol, abs_tol
logical, intent(in), optional :: equal_nan
end function is_close_${t1[0]}$${k1}$
#:endfor
end interface is_close
!> Version: experimental
!>
!> Returns a boolean scalar where two arrays are element-wise equal within a tolerance.
!> ([Specification](../page/specs/stdlib_math.html#all_close-function))
interface all_close
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set RANKS = range(1, MAXRANK + 1)
#:for k1, t1 in RC_KINDS_TYPES
#:for r1 in RANKS
logical pure module function all_close_${r1}$_${t1[0]}$${k1}$(a, b, rel_tol, abs_tol, equal_nan) result(close)
${t1}$, intent(in) :: a${ranksuffix(r1)}$, b${ranksuffix(r1)}$
real(${k1}$), intent(in), optional :: rel_tol, abs_tol
logical, intent(in), optional :: equal_nan
end function all_close_${r1}$_${t1[0]}$${k1}$
#:endfor
#:endfor
end interface all_close
!> Version: experimental
!>
!> Computes differences between adjacent elements of an array.
!> ([Specification](../page/specs/stdlib_math.html#diff-function))
interface diff
#:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES
#:for k1, t1 in RI_KINDS_TYPES
pure module function diff_1_${k1}$(x, n, prepend, append) result(y)
${t1}$, intent(in) :: x(:)
integer, intent(in), optional :: n
${t1}$, intent(in), optional :: prepend(:), append(:)
${t1}$, allocatable :: y(:)
end function diff_1_${k1}$
pure module function diff_2_${k1}$(X, n, dim, prepend, append) result(y)
${t1}$, intent(in) :: x(:, :)
integer, intent(in), optional :: n, dim
${t1}$, intent(in), optional :: prepend(:, :), append(:, :)
${t1}$, allocatable :: y(:, :)
end function diff_2_${k1}$
#:endfor
end interface diff
!> Version: experimental
!>
!> Computes a list of coordinate matrices from coordinate vectors.
!> ([Specification](../page/specs/stdlib_math.html#meshgrid))
interface meshgrid
#:set RANKS = range(1, MAXRANK + 1)
#:for k1, t1 in IR_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("meshgrid", rank, t1, k1)
module subroutine ${RName}$(&
${"".join(f"x{i}, " for i in range(1, rank + 1))}$ &
${"".join(f"xm{i}, " for i in range(1, rank + 1))}$ &
indexing &
)
#:for i in range(1, rank + 1)
${t1}$, intent(in) :: x${i}$(:)
${t1}$, intent(out) :: xm${i}$ ${ranksuffix(rank)}$
#:endfor
integer, intent(in), optional :: indexing
end subroutine ${RName}$
#:endfor
#:endfor
end interface meshgrid
contains
#:for k1, t1 in IR_KINDS_TYPES
elemental function clip_${k1}$(x, xmin, xmax) result(res)
${t1}$, intent(in) :: x
${t1}$, intent(in) :: xmin
${t1}$, intent(in) :: xmax
${t1}$ :: res
res = max(min(x, xmax), xmin)
end function clip_${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function arg_${k1}$(z) result(result)
${t1}$, intent(in) :: z
real(${k1}$) :: result
result = merge(0.0_${k1}$, atan2(z%im, z%re), z == (0.0_${k1}$, 0.0_${k1}$))
end function arg_${k1}$
elemental function argd_${k1}$(z) result(result)
${t1}$, intent(in) :: z
real(${k1}$) :: result
result = merge(0.0_${k1}$, atan2(z%im, z%re)*180.0_${k1}$/PI_${k1}$, &
z == (0.0_${k1}$, 0.0_${k1}$))
end function argd_${k1}$
elemental function argpi_${k1}$(z) result(result)
${t1}$, intent(in) :: z
real(${k1}$) :: result
result = merge(0.0_${k1}$, atan2(z%im, z%re)/PI_${k1}$, &
z == (0.0_${k1}$, 0.0_${k1}$))
end function argpi_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function deg2rad_${k1}$(theta) result(result)
${t1}$, intent(in) :: theta
${t1}$ :: result
result = theta * PI_${k1}$ / 180.0_${k1}$
end function deg2rad_${k1}$
elemental function rad2deg_${k1}$(theta) result(result)
${t1}$, intent(in) :: theta
${t1}$ :: result
result = theta * 180.0_${k1}$ / PI_${k1}$
end function rad2deg_${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
!> Returns the greatest common divisor of two integers of kind ${k1}$
!> using the Euclidean algorithm.
elemental function gcd_${k1}$(a, b) result(res)
${t1}$, intent(in) :: a
${t1}$, intent(in) :: b
${t1}$ :: res
${t1}$ :: rem, tmp
rem = min(abs(a), abs(b))
res = max(abs(a), abs(b))
do while (rem /= 0_${k1}$)
tmp = rem
rem = mod(res, rem)
res = tmp
end do
end function gcd_${k1}$
#:endfor
#:for k1, t1, a1, cpp1 in INT_KINDS_TYPES + REAL_KINDS_TYPES + BITSETS_KINDS_TYPES
#:block generate_cpp(cpp_var=cpp1)
elemental subroutine swap_${k1}$(lhs, rhs)
${t1}$, intent(inout) :: lhs, rhs
${t1}$ :: temp
temp = lhs; lhs = rhs; rhs = temp
end subroutine
#:endblock
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental subroutine swap_c${k1}$(lhs, rhs)
${t1}$, intent(inout) :: lhs, rhs
${t1}$ :: temp
temp = lhs; lhs = rhs; rhs = temp
end subroutine
#:endfor
elemental subroutine swap_bool(lhs, rhs)
logical, intent(inout) :: lhs, rhs
logical :: temp
temp = lhs; lhs = rhs; rhs = temp
end subroutine
elemental subroutine swap_str(lhs,rhs)
character(*), intent(inout) :: lhs, rhs
character(len=max(len(lhs), len(rhs))) :: temp
temp = lhs ; lhs = rhs ; rhs = temp
end subroutine
elemental subroutine swap_stt(lhs,rhs)
use stdlib_string_type, only: string_type
type(string_type), intent(inout) :: lhs, rhs
type(string_type) :: temp
temp = lhs ; lhs = rhs ; rhs = temp
end subroutine
end module stdlib_math
fortran-lang-stdlib-0ede301/src/math/stdlib_math_diff.fypp 0000664 0001750 0001750 00000010534 15135654166 024073 0 ustar alastair alastair !> Inspired by original code (MIT license) written in 2016 by Keurfon Luu (keurfonluu@outlook.com)
!> https://github.com/keurfonluu/Forlab
#:include "common.fypp"
#:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES
submodule (stdlib_math) stdlib_math_diff
implicit none
contains
!> `diff` computes differences of adjacent elements of an array.
#:for k1, t1 in RI_KINDS_TYPES
pure module function diff_1_${k1}$(x, n, prepend, append) result(y)
${t1}$, intent(in) :: x(:)
integer, intent(in), optional :: n
${t1}$, intent(in), optional :: prepend(:), append(:)
${t1}$, allocatable :: y(:)
integer :: size_prepend, size_append, size_x, size_work
integer :: n_, i
n_ = optval(n, 1)
if (n_ <= 0) then
y = x
return
end if
size_prepend = 0
size_append = 0
if (present(prepend)) size_prepend = size(prepend)
if (present(append)) size_append = size(append)
size_x = size(x)
size_work = size_x + size_prepend + size_append
if (size_work <= n_) then
allocate(y(0))
return
end if
!> Use a quick exit for the common case, to avoid memory allocation.
if (size_prepend == 0 .and. size_append == 0 .and. n_ == 1) then
y = x(2:) - x(1:size_x-1)
return
end if
block
${t1}$ :: work(size_work)
if (size_prepend > 0) work(:size_prepend) = prepend
work(size_prepend+1:size_prepend+size_x) = x
if (size_append > 0) work(size_prepend+size_x+1:) = append
do i = 1, n_
work(1:size_work-i) = work(2:size_work-i+1) - work(1:size_work-i)
end do
y = work(1:size_work-n_)
end block
end function diff_1_${k1}$
pure module function diff_2_${k1}$(x, n, dim, prepend, append) result(y)
${t1}$, intent(in) :: x(:, :)
integer, intent(in), optional :: n, dim
${t1}$, intent(in), optional :: prepend(:, :), append(:, :)
${t1}$, allocatable :: y(:, :)
integer :: size_prepend, size_append, size_x, size_work
integer :: n_, dim_, i
n_ = optval(n, 1)
if (n_ <= 0) then
y = x
return
end if
size_prepend = 0
size_append = 0
if (present(dim)) then
if (dim == 1 .or. dim == 2) then
dim_ = dim
else
dim_ = 1
end if
else
dim_ = 1
end if
if (present(prepend)) size_prepend = size(prepend, dim_)
if (present(append)) size_append = size(append, dim_)
size_x = size(x, dim_)
size_work = size_x + size_prepend + size_append
if (size_work <= n_) then
allocate(y(0, 0))
return
end if
!> Use a quick exit for the common case, to avoid memory allocation.
if (size_prepend == 0 .and. size_append == 0 .and. n_ == 1) then
if (dim_ == 1) then
y = x(2:, :) - x(1:size_x-1, :)
elseif (dim_ == 2) then
y = x(:, 2:) - x(:, 1:size_x-1)
end if
return
end if
if (dim_ == 1) then
block
${t1}$ :: work(size_work, size(x, 2))
if (size_prepend > 0) work(1:size_prepend, :) = prepend
work(size_prepend+1:size_x+size_prepend, :) = x
if (size_append > 0) work(size_x+size_prepend+1:, :) = append
do i = 1, n_
work(1:size_work-i, :) = work(2:size_work-i+1, :) - work(1:size_work-i, :)
end do
y = work(1:size_work-n_, :)
end block
elseif (dim_ == 2) then
block
${t1}$ :: work(size(x, 1), size_work)
if (size_prepend > 0) work(:, 1:size_prepend) = prepend
work(:, size_prepend+1:size_x+size_prepend) = x
if (size_append > 0) work(:, size_x+size_prepend+1:) = append
do i = 1, n_
work(:, 1:size_work-i) = work(:, 2:size_work-i+1) - work(:, 1:size_work-i)
end do
y = work(:, 1:size_work-n_)
end block
end if
end function diff_2_${k1}$
#:endfor
end submodule stdlib_math_diff fortran-lang-stdlib-0ede301/src/CMakeLists.txt 0000664 0001750 0001750 00000002743 15135654166 021523 0 ustar alastair alastair macro(ADD_SUBDIR name)
string(TOUPPER "${name}" uname)
if (STDLIB_${uname})
add_subdirectory(${name})
list(APPEND OPTIONAL_LIB ${PROJECT_NAME}_${name})
endif()
endmacro()
set(OPTIONAL_LIB)
ADD_SUBDIR(ansi)
add_subdirectory(array)
ADD_SUBDIR(bitsets)
add_subdirectory(blas)
add_subdirectory(constants)
add_subdirectory(core)
add_subdirectory(hash)
ADD_SUBDIR(hashmaps)
add_subdirectory(intrinsics)
ADD_SUBDIR(io)
add_subdirectory(lapack)
add_subdirectory(lapack_extended)
add_subdirectory(linalg_core)
ADD_SUBDIR(linalg_iterative)
add_subdirectory(linalg)
ADD_SUBDIR(logger)
add_subdirectory(math)
ADD_SUBDIR(quadrature)
add_subdirectory(selection)
add_subdirectory(sorting)
add_subdirectory(specialfunctions)
ADD_SUBDIR(specialmatrices)
ADD_SUBDIR(stringlist)
add_subdirectory(strings)
ADD_SUBDIR(system)
ADD_SUBDIR(stats)
add_subdirectory(sparse)
set(fppFiles
stdlib_version.fypp
)
set(cppFiles
)
set(f90Files
)
configure_stdlib_target(${PROJECT_NAME} f90Files fppFiles cppFiles)
target_link_libraries(${PROJECT_NAME} PUBLIC
${PROJECT_NAME}_array
${PROJECT_NAME}_constants
${PROJECT_NAME}_core
${PROJECT_NAME}_hash
${PROJECT_NAME}_intrinsics
${PROJECT_NAME}_linalg_core
${PROJECT_NAME}_linalg
${PROJECT_NAME}_math
${PROJECT_NAME}_selection
${PROJECT_NAME}_specialfunctions
${PROJECT_NAME}_sorting
${PROJECT_NAME}_strings
${PROJECT_NAME}_blas ${PROJECT_NAME}_lapack ${PROJECT_NAME}_lapack_extended
${PROJECT_NAME}_sparse
${OPTIONAL_LIB}
)
fortran-lang-stdlib-0ede301/src/constants/ 0000775 0001750 0001750 00000000000 15135654166 020771 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/constants/stdlib_constants.fypp 0000664 0001750 0001750 00000011441 15135654166 025247 0 ustar alastair alastair #:include "common.fypp"
#:set KINDS = REAL_KINDS
#:set I_KINDS_TYPES = list(zip(INT_KINDS, INT_TYPES, INT_KINDS))
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
module stdlib_constants
!! Constants
!! ([Specification](../page/specs/stdlib_constants.html))
use stdlib_kinds
use stdlib_codata, only: SPEED_OF_LIGHT_IN_VACUUM, &
VACUUM_ELECTRIC_PERMITTIVITY, &
VACUUM_MAG_PERMEABILITY, &
PLANCK_CONSTANT, &
NEWTONIAN_CONSTANT_OF_GRAVITATION, &
STANDARD_ACCELERATION_OF_GRAVITY, &
ELEMENTARY_CHARGE, &
MOLAR_GAS_CONSTANT, &
FINE_STRUCTURE_CONSTANT, &
AVOGADRO_CONSTANT, &
BOLTZMANN_CONSTANT, &
STEFAN_BOLTZMANN_CONSTANT, &
WIEN_WAVELENGTH_DISPLACEMENT_LAW_CONSTANT, &
RYDBERG_CONSTANT, &
ELECTRON_MASS, &
PROTON_MASS, &
NEUTRON_MASS, &
ATOMIC_MASS_CONSTANT
private
! mathematical constants
#:for k in KINDS
real(${k}$), parameter, public :: PI_${k}$ = acos(-1.0_${k}$) !! PI
#:endfor
! Physical constants
real(dp), parameter, public :: c = SPEED_OF_LIGHT_IN_VACUUM%value !! Speed of light in vacuum
real(dp), parameter, public :: speed_of_light = SPEED_OF_LIGHT_IN_VACUUM%value !! Speed of light in vacuum
real(dp), parameter, public :: mu_0 = VACUUM_MAG_PERMEABILITY%value !! vacuum mag. permeability
real(dp), parameter, public :: epsilon_0 = VACUUM_ELECTRIC_PERMITTIVITY%value !! vacuum mag. permeability
real(dp), parameter, public :: h = PLANCK_CONSTANT%value !! Planck constant
real(dp), parameter, public :: Planck = PLANCK_CONSTANT%value !! Planck constant
real(dp), parameter, public :: hbar = PLANCK_CONSTANT%value / (2.0_dp * PI_dp) !! Reduced Planck constant
real(dp), parameter, public :: G = NEWTONIAN_CONSTANT_OF_GRAVITATION%value !! Newtonian constant of gravitation
real(dp), parameter, public :: gravitation_constant = NEWTONIAN_CONSTANT_OF_GRAVITATION%value !! Newtonian constant of gravitation
real(dp), parameter, public :: g2 = STANDARD_ACCELERATION_OF_GRAVITY%value !! Standard acceleration of gravity
real(dp), parameter, public :: e = ELEMENTARY_CHARGE%value !! Elementary charge
real(dp), parameter, public :: R = MOLAR_GAS_CONSTANT%value !! Molar gas constant
real(dp), parameter, public :: gas_constant = MOLAR_GAS_CONSTANT%value !! Molar gas constant
real(dp), parameter, public :: alpha = FINE_STRUCTURE_CONSTANT%value !! Fine structure constant
real(dp), parameter, public :: fine_structure = FINE_STRUCTURE_CONSTANT%value !! Fine structure constant
real(dp), parameter, public :: N_A = AVOGADRO_CONSTANT%value !! Avogadro constant
real(dp), parameter, public :: Avogadro = AVOGADRO_CONSTANT%value !! Avogadro constant
real(dp), parameter, public :: k = BOLTZMANN_CONSTANT%value !! Boltzmann constant
real(dp), parameter, public :: Boltzmann = BOLTZMANN_CONSTANT%value !! Boltzmann constant
real(dp), parameter, public :: sigma = STEFAN_BOLTZMANN_CONSTANT%value !! Stefan-Boltzmann constant
real(dp), parameter, public :: Stefan_Boltzmann = STEFAN_BOLTZMANN_CONSTANT%value !! Stefan-Boltzmann constant
real(dp), parameter, public :: Wien = WIEN_WAVELENGTH_DISPLACEMENT_LAW_CONSTANT%value !! Wien wavelength displacement law constant
real(dp), parameter, public :: Rydberg = RYDBERG_CONSTANT%value !! Rydberg constant
real(dp), parameter, public :: m_e = ELECTRON_MASS%value !! Electron mass
real(dp), parameter, public :: m_p = PROTON_MASS%value !! Proton mass
real(dp), parameter, public :: m_n = NEUTRON_MASS%value !! Neutron mass
real(dp), parameter, public :: m_u = ATOMIC_MASS_CONSTANT%value !! Atomic mass constant
real(dp), parameter, public :: u = ATOMIC_MASS_CONSTANT%value !! Atomic mass constant
! Additional constants if needed
#:for k, t, s in I_KINDS_TYPES
${t}$, parameter, public :: zero_${s}$ = 0_${k}$
${t}$, parameter, public :: one_${s}$ = 1_${k}$
#:endfor
#:for k, t, s in R_KINDS_TYPES
${t}$, parameter, public :: zero_${s}$ = 0._${k}$
${t}$, parameter, public :: one_${s}$ = 1._${k}$
${t}$, parameter, public :: log2_${s}$ = log(2.0_${k}$)
#:endfor
#:for k, t, s in C_KINDS_TYPES
${t}$, parameter, public :: zero_${s}$ = (0._${k}$,0._${k}$)
${t}$, parameter, public :: one_${s}$ = (1._${k}$,0._${k}$)
#:endfor
end module stdlib_constants
fortran-lang-stdlib-0ede301/src/constants/stdlib_codata_type.fypp 0000664 0001750 0001750 00000004270 15135654166 025531 0 ustar alastair alastair #:include "common.fypp"
#:set KINDS = REAL_KINDS
module stdlib_codata_type
!! Codata constant type
!! ([Specification](../page/specs/stdlib_constants.html))
use stdlib_kinds, only: #{for k in KINDS[:-1]}#${k}$, #{endfor}#${KINDS[-1]}$
use stdlib_io_aux, only: FMT_REAL_DP
use stdlib_optval, only: optval
private
type, public :: codata_constant_type
!! version: experimental
!!
!! Derived type for representing a Codata constant.
!! ([Specification](../page/specs/stdlib_constants.html))
character(len=64) :: name
real(dp) :: value
real(dp) :: uncertainty
character(len=32) :: unit
contains
procedure :: print
#:for k in KINDS
procedure :: to_real_${k}$
#:endfor
generic :: to_real => #{for k in KINDS[:-1]}#to_real_${k}$, #{endfor}#to_real_${KINDS[-1]}$
end type
interface to_real
!! Get the constant value or uncertainty.
#:for k in KINDS
module procedure to_real_${k}$
#:endfor
end interface
public :: to_real
contains
subroutine print(self)
!! Print out the constant's name, value, uncertainty and unit.
class(codata_constant_type), intent(in) :: self
print "(A64, SP, "//FMT_REAL_DP//", A5, "//FMT_REAL_DP//", 1X, A32)", self%name, self%value, "+/-", self%uncertainty, self%unit
end subroutine
#:for k in KINDS
elemental pure real(${k}$) function to_real_${k}$(self, mold, uncertainty) result(r)
!! version: experimental
!!
!! Get the constant value or uncertainty for the kind ${k}$
!! ([Specification](../page/specs/stdlib_constants.html))
class(codata_constant_type), intent(in) :: self !! Codata constant
real(${k}$), intent(in) :: mold !! dummy argument to disambiguate at compile time the generic interface
logical, intent(in), optional :: uncertainty !! Set to true if the uncertainty is required. Default to .false..
!!
logical :: u
u = optval(uncertainty, .false.)
if(u .eqv. .false.)then
r = real(self%value, kind(mold))
else
r = real(self%uncertainty, kind(mold))
end if
end function
#:endfor
end module stdlib_codata_type
fortran-lang-stdlib-0ede301/src/constants/stdlib_codata.f90 0000664 0001750 0001750 00000224512 15135654166 024113 0 ustar alastair alastair module stdlib_codata
!! Codata Constants - Autogenerated
use stdlib_kinds, only: dp, int32
use stdlib_codata_type
private
integer(int32), parameter, public :: YEAR = 2022 !! Year of release.
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_ELECTRON_MASS_RATIO = &
codata_constant_type("alpha particle-electron mass ratio", &
7294.29954171_dp, 0.00000017_dp, &
"") !! alpha particle-electron mass ratio
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_MASS = &
codata_constant_type("alpha particle mass", &
6.6446573450e-27_dp, 0.0000000021e-27_dp, &
"kg") !! alpha particle mass
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("alpha particle mass energy equivalent", &
5.9719201997e-10_dp, 0.0000000019e-10_dp, &
"J") !! alpha particle mass energy equivalent
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_MASS_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("alpha particle mass energy equivalent in MeV", &
3727.3794118_dp, 0.0000012_dp, &
"MeV") !! alpha particle mass energy equivalent in MeV
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_MASS_IN_U = &
codata_constant_type("alpha particle mass in u", &
4.001506179129_dp, 0.000000000062_dp, &
"u") !! alpha particle mass in u
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_MOLAR_MASS = &
codata_constant_type("alpha particle molar mass", &
4.0015061833e-3_dp, 0.0000000012e-3_dp, &
"kg mol^-1") !! alpha particle molar mass
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_PROTON_MASS_RATIO = &
codata_constant_type("alpha particle-proton mass ratio", &
3.972599690252_dp, 0.000000000070_dp, &
"") !! alpha particle-proton mass ratio
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_RELATIVE_ATOMIC_MASS = &
codata_constant_type("alpha particle relative atomic mass", &
4.001506179129_dp, 0.000000000062_dp, &
"") !! alpha particle relative atomic mass
type(codata_constant_type), parameter, public :: ALPHA_PARTICLE_RMS_CHARGE_RADIUS = &
codata_constant_type("alpha particle rms charge radius", &
1.6785e-15_dp, 0.0021e-15_dp, &
"m") !! alpha particle rms charge radius
type(codata_constant_type), parameter, public :: ANGSTROM_STAR = &
codata_constant_type("Angstrom star", &
1.00001495e-10_dp, 0.00000090e-10_dp, &
"m") !! Angstrom star
type(codata_constant_type), parameter, public :: ATOMIC_MASS_CONSTANT = &
codata_constant_type("atomic mass constant", &
1.66053906892e-27_dp, 0.00000000052e-27_dp, &
"kg") !! atomic mass constant
type(codata_constant_type), parameter, public :: ATOMIC_MASS_CONSTANT_ENERGY_EQUIVALENT = &
codata_constant_type("atomic mass constant energy equivalent", &
1.49241808768e-10_dp, 0.00000000046e-10_dp, &
"J") !! atomic mass constant energy equivalent
type(codata_constant_type), parameter, public :: ATOMIC_MASS_CONSTANT_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("atomic mass constant energy equivalent in MeV", &
931.49410372_dp, 0.00000029_dp, &
"MeV") !! atomic mass constant energy equivalent in MeV
type(codata_constant_type), parameter, public :: ATOMIC_MASS_UNIT_ELECTRON_VOLT_RELATIONSHIP = &
codata_constant_type("atomic mass unit-electron volt relationship", &
9.3149410372e8_dp, 0.0000000029e8_dp, &
"eV") !! atomic mass unit-electron volt relationship
type(codata_constant_type), parameter, public :: ATOMIC_MASS_UNIT_HARTREE_RELATIONSHIP = &
codata_constant_type("atomic mass unit-hartree relationship", &
3.4231776922e7_dp, 0.0000000011e7_dp, &
"E_h") !! atomic mass unit-hartree relationship
type(codata_constant_type), parameter, public :: ATOMIC_MASS_UNIT_HERTZ_RELATIONSHIP = &
codata_constant_type("atomic mass unit-hertz relationship", &
2.25234272185e23_dp, 0.00000000070e23_dp, &
"Hz") !! atomic mass unit-hertz relationship
type(codata_constant_type), parameter, public :: ATOMIC_MASS_UNIT_INVERSE_METER_RELATIONSHIP = &
codata_constant_type("atomic mass unit-inverse meter relationship", &
7.5130066209e14_dp, 0.0000000023e14_dp, &
"m^-1") !! atomic mass unit-inverse meter relationship
type(codata_constant_type), parameter, public :: ATOMIC_MASS_UNIT_JOULE_RELATIONSHIP = &
codata_constant_type("atomic mass unit-joule relationship", &
1.49241808768e-10_dp, 0.00000000046e-10_dp, &
"J") !! atomic mass unit-joule relationship
type(codata_constant_type), parameter, public :: ATOMIC_MASS_UNIT_KELVIN_RELATIONSHIP = &
codata_constant_type("atomic mass unit-kelvin relationship", &
1.08095402067e13_dp, 0.00000000034e13_dp, &
"K") !! atomic mass unit-kelvin relationship
type(codata_constant_type), parameter, public :: ATOMIC_MASS_UNIT_KILOGRAM_RELATIONSHIP = &
codata_constant_type("atomic mass unit-kilogram relationship", &
1.66053906892e-27_dp, 0.00000000052e-27_dp, &
"kg") !! atomic mass unit-kilogram relationship
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_1ST_HYPERPOLARIZABILITY = &
codata_constant_type("atomic unit of 1st hyperpolarizability", &
3.2063612996e-53_dp, 0.0000000015e-53_dp, &
"C^3 m^3 J^-2") !! atomic unit of 1st hyperpolarizability
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_2ND_HYPERPOLARIZABILITY = &
codata_constant_type("atomic unit of 2nd hyperpolarizability", &
6.2353799735e-65_dp, 0.0000000039e-65_dp, &
"C^4 m^4 J^-3") !! atomic unit of 2nd hyperpolarizability
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_ACTION = &
codata_constant_type("atomic unit of action", &
1.054571817e-34_dp, 0.0_dp, &
"J s") !! atomic unit of action
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_CHARGE = &
codata_constant_type("atomic unit of charge", &
1.602176634e-19_dp, 0.0_dp, &
"C") !! atomic unit of charge
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_CHARGE_DENSITY = &
codata_constant_type("atomic unit of charge density", &
1.08120238677e12_dp, 0.00000000051e12_dp, &
"C m^-3") !! atomic unit of charge density
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_CURRENT = &
codata_constant_type("atomic unit of current", &
6.6236182375082e-3_dp, 0.0000000000072e-3_dp, &
"A") !! atomic unit of current
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_ELECTRIC_DIPOLE_MOM = &
codata_constant_type("atomic unit of electric dipole mom.", &
8.4783536198e-30_dp, 0.0000000013e-30_dp, &
"C m") !! atomic unit of electric dipole mom.
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_ELECTRIC_FIELD = &
codata_constant_type("atomic unit of electric field", &
5.14220675112e11_dp, 0.00000000080e11_dp, &
"V m^-1") !! atomic unit of electric field
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_ELECTRIC_FIELD_GRADIENT = &
codata_constant_type("atomic unit of electric field gradient", &
9.7173624424e21_dp, 0.0000000030e21_dp, &
"V m^-2") !! atomic unit of electric field gradient
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_ELECTRIC_POLARIZABILITY = &
codata_constant_type("atomic unit of electric polarizability", &
1.64877727212e-41_dp, 0.00000000051e-41_dp, &
"C^2 m^2 J^-1") !! atomic unit of electric polarizability
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_ELECTRIC_POTENTIAL = &
codata_constant_type("atomic unit of electric potential", &
27.211386245981_dp, 0.000000000030_dp, &
"V") !! atomic unit of electric potential
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_ELECTRIC_QUADRUPOLE_MOM = &
codata_constant_type("atomic unit of electric quadrupole mom.", &
4.4865515185e-40_dp, 0.0000000014e-40_dp, &
"C m^2") !! atomic unit of electric quadrupole mom.
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_ENERGY = &
codata_constant_type("atomic unit of energy", &
4.3597447222060e-18_dp, 0.0000000000048e-18_dp, &
"J") !! atomic unit of energy
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_FORCE = &
codata_constant_type("atomic unit of force", &
8.2387235038e-8_dp, 0.0000000013e-8_dp, &
"N") !! atomic unit of force
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_LENGTH = &
codata_constant_type("atomic unit of length", &
5.29177210544e-11_dp, 0.00000000082e-11_dp, &
"m") !! atomic unit of length
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_MAG_DIPOLE_MOM = &
codata_constant_type("atomic unit of mag. dipole mom.", &
1.85480201315e-23_dp, 0.00000000058e-23_dp, &
"J T^-1") !! atomic unit of mag. dipole mom.
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_MAG_FLUX_DENSITY = &
codata_constant_type("atomic unit of mag. flux density", &
2.35051757077e5_dp, 0.00000000073e5_dp, &
"T") !! atomic unit of mag. flux density
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_MAGNETIZABILITY = &
codata_constant_type("atomic unit of magnetizability", &
7.8910365794e-29_dp, 0.0000000049e-29_dp, &
"J T^-2") !! atomic unit of magnetizability
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_MASS = &
codata_constant_type("atomic unit of mass", &
9.1093837139e-31_dp, 0.0000000028e-31_dp, &
"kg") !! atomic unit of mass
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_MOMENTUM = &
codata_constant_type("atomic unit of momentum", &
1.99285191545e-24_dp, 0.00000000031e-24_dp, &
"kg m s^-1") !! atomic unit of momentum
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_PERMITTIVITY = &
codata_constant_type("atomic unit of permittivity", &
1.11265005620e-10_dp, 0.00000000017e-10_dp, &
"F m^-1") !! atomic unit of permittivity
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_TIME = &
codata_constant_type("atomic unit of time", &
2.4188843265864e-17_dp, 0.0000000000026e-17_dp, &
"s") !! atomic unit of time
type(codata_constant_type), parameter, public :: ATOMIC_UNIT_OF_VELOCITY = &
codata_constant_type("atomic unit of velocity", &
2.18769126216e6_dp, 0.00000000034e6_dp, &
"m s^-1") !! atomic unit of velocity
type(codata_constant_type), parameter, public :: AVOGADRO_CONSTANT = &
codata_constant_type("Avogadro constant", &
6.02214076e23_dp, 0.0_dp, &
"mol^-1") !! Avogadro constant
type(codata_constant_type), parameter, public :: BOHR_MAGNETON = &
codata_constant_type("Bohr magneton", &
9.2740100657e-24_dp, 0.0000000029e-24_dp, &
"J T^-1") !! Bohr magneton
type(codata_constant_type), parameter, public :: BOHR_MAGNETON_IN_EV_T = &
codata_constant_type("Bohr magneton in eV/T", &
5.7883817982e-5_dp, 0.0000000018e-5_dp, &
"eV T^-1") !! Bohr magneton in eV/T
type(codata_constant_type), parameter, public :: BOHR_MAGNETON_IN_HZ_T = &
codata_constant_type("Bohr magneton in Hz/T", &
1.39962449171e10_dp, 0.00000000044e10_dp, &
"Hz T^-1") !! Bohr magneton in Hz/T
type(codata_constant_type), parameter, public :: BOHR_MAGNETON_IN_INVERSE_METER_PER_TESLA = &
codata_constant_type("Bohr magneton in inverse meter per tesla", &
46.686447719_dp, 0.000000015_dp, &
"m^-1 T^-1") !! Bohr magneton in inverse meter per tesla
type(codata_constant_type), parameter, public :: BOHR_MAGNETON_IN_K_T = &
codata_constant_type("Bohr magneton in K/T", &
0.67171381472_dp, 0.00000000021_dp, &
"K T^-1") !! Bohr magneton in K/T
type(codata_constant_type), parameter, public :: BOHR_RADIUS = &
codata_constant_type("Bohr radius", &
5.29177210544e-11_dp, 0.00000000082e-11_dp, &
"m") !! Bohr radius
type(codata_constant_type), parameter, public :: BOLTZMANN_CONSTANT = &
codata_constant_type("Boltzmann constant", &
1.380649e-23_dp, 0.0_dp, &
"J K^-1") !! Boltzmann constant
type(codata_constant_type), parameter, public :: BOLTZMANN_CONSTANT_IN_EV_K = &
codata_constant_type("Boltzmann constant in eV/K", &
8.617333262e-5_dp, 0.0_dp, &
"eV K^-1") !! Boltzmann constant in eV/K
type(codata_constant_type), parameter, public :: BOLTZMANN_CONSTANT_IN_HZ_K = &
codata_constant_type("Boltzmann constant in Hz/K", &
2.083661912e10_dp, 0.0_dp, &
"Hz K^-1") !! Boltzmann constant in Hz/K
type(codata_constant_type), parameter, public :: BOLTZMANN_CONSTANT_IN_INVERSE_METER_PER_KELVIN = &
codata_constant_type("Boltzmann constant in inverse meter per kelvin", &
69.50348004_dp, 0.0_dp, &
"m^-1 K^-1") !! Boltzmann constant in inverse meter per kelvin
type(codata_constant_type), parameter, public :: CHARACTERISTIC_IMPEDANCE_OF_VACUUM = &
codata_constant_type("characteristic impedance of vacuum", &
376.730313412_dp, 0.000000059_dp, &
"ohm") !! characteristic impedance of vacuum
type(codata_constant_type), parameter, public :: CLASSICAL_ELECTRON_RADIUS = &
codata_constant_type("classical electron radius", &
2.8179403205e-15_dp, 0.0000000013e-15_dp, &
"m") !! classical electron radius
type(codata_constant_type), parameter, public :: COMPTON_WAVELENGTH = &
codata_constant_type("Compton wavelength", &
2.42631023538e-12_dp, 0.00000000076e-12_dp, &
"m") !! Compton wavelength
type(codata_constant_type), parameter, public :: CONDUCTANCE_QUANTUM = &
codata_constant_type("conductance quantum", &
7.748091729e-5_dp, 0.0_dp, &
"S") !! conductance quantum
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_AMPERE_90 = &
codata_constant_type("conventional value of ampere-90", &
1.00000008887_dp, 0.0_dp, &
"A") !! conventional value of ampere-90
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_COULOMB_90 = &
codata_constant_type("conventional value of coulomb-90", &
1.00000008887_dp, 0.0_dp, &
"C") !! conventional value of coulomb-90
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_FARAD_90 = &
codata_constant_type("conventional value of farad-90", &
0.99999998220_dp, 0.0_dp, &
"F") !! conventional value of farad-90
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_HENRY_90 = &
codata_constant_type("conventional value of henry-90", &
1.00000001779_dp, 0.0_dp, &
"H") !! conventional value of henry-90
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_JOSEPHSON_CONSTANT = &
codata_constant_type("conventional value of Josephson constant", &
483597.9e9_dp, 0.0_dp, &
"Hz V^-1") !! conventional value of Josephson constant
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_OHM_90 = &
codata_constant_type("conventional value of ohm-90", &
1.00000001779_dp, 0.0_dp, &
"ohm") !! conventional value of ohm-90
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_VOLT_90 = &
codata_constant_type("conventional value of volt-90", &
1.00000010666_dp, 0.0_dp, &
"V") !! conventional value of volt-90
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_VON_KLITZING_CONSTANT = &
codata_constant_type("conventional value of von Klitzing constant", &
25812.807_dp, 0.0_dp, &
"ohm") !! conventional value of von Klitzing constant
type(codata_constant_type), parameter, public :: CONVENTIONAL_VALUE_OF_WATT_90 = &
codata_constant_type("conventional value of watt-90", &
1.00000019553_dp, 0.0_dp, &
"W") !! conventional value of watt-90
type(codata_constant_type), parameter, public :: COPPER_X_UNIT = &
codata_constant_type("Copper x unit", &
1.00207697e-13_dp, 0.00000028e-13_dp, &
"m") !! Copper x unit
type(codata_constant_type), parameter, public :: DEUTERON_ELECTRON_MAG_MOM_RATIO = &
codata_constant_type("deuteron-electron mag. mom. ratio", &
-4.664345550e-4_dp, 0.000000012e-4_dp, &
"") !! deuteron-electron mag. mom. ratio
type(codata_constant_type), parameter, public :: DEUTERON_ELECTRON_MASS_RATIO = &
codata_constant_type("deuteron-electron mass ratio", &
3670.482967655_dp, 0.000000063_dp, &
"") !! deuteron-electron mass ratio
type(codata_constant_type), parameter, public :: DEUTERON_G_FACTOR = &
codata_constant_type("deuteron g factor", &
0.8574382335_dp, 0.0000000022_dp, &
"") !! deuteron g factor
type(codata_constant_type), parameter, public :: DEUTERON_MAG_MOM = &
codata_constant_type("deuteron mag. mom.", &
4.330735087e-27_dp, 0.000000011e-27_dp, &
"J T^-1") !! deuteron mag. mom.
type(codata_constant_type), parameter, public :: DEUTERON_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("deuteron mag. mom. to Bohr magneton ratio", &
4.669754568e-4_dp, 0.000000012e-4_dp, &
"") !! deuteron mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: DEUTERON_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("deuteron mag. mom. to nuclear magneton ratio", &
0.8574382335_dp, 0.0000000022_dp, &
"") !! deuteron mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: DEUTERON_MASS = &
codata_constant_type("deuteron mass", &
3.3435837768e-27_dp, 0.0000000010e-27_dp, &
"kg") !! deuteron mass
type(codata_constant_type), parameter, public :: DEUTERON_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("deuteron mass energy equivalent", &
3.00506323491e-10_dp, 0.00000000094e-10_dp, &
"J") !! deuteron mass energy equivalent
type(codata_constant_type), parameter, public :: DEUTERON_MASS_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("deuteron mass energy equivalent in MeV", &
1875.61294500_dp, 0.00000058_dp, &
"MeV") !! deuteron mass energy equivalent in MeV
type(codata_constant_type), parameter, public :: DEUTERON_MASS_IN_U = &
codata_constant_type("deuteron mass in u", &
2.013553212544_dp, 0.000000000015_dp, &
"u") !! deuteron mass in u
type(codata_constant_type), parameter, public :: DEUTERON_MOLAR_MASS = &
codata_constant_type("deuteron molar mass", &
2.01355321466e-3_dp, 0.00000000063e-3_dp, &
"kg mol^-1") !! deuteron molar mass
type(codata_constant_type), parameter, public :: DEUTERON_NEUTRON_MAG_MOM_RATIO = &
codata_constant_type("deuteron-neutron mag. mom. ratio", &
-0.44820652_dp, 0.00000011_dp, &
"") !! deuteron-neutron mag. mom. ratio
type(codata_constant_type), parameter, public :: DEUTERON_PROTON_MAG_MOM_RATIO = &
codata_constant_type("deuteron-proton mag. mom. ratio", &
0.30701220930_dp, 0.00000000079_dp, &
"") !! deuteron-proton mag. mom. ratio
type(codata_constant_type), parameter, public :: DEUTERON_PROTON_MASS_RATIO = &
codata_constant_type("deuteron-proton mass ratio", &
1.9990075012699_dp, 0.0000000000084_dp, &
"") !! deuteron-proton mass ratio
type(codata_constant_type), parameter, public :: DEUTERON_RELATIVE_ATOMIC_MASS = &
codata_constant_type("deuteron relative atomic mass", &
2.013553212544_dp, 0.000000000015_dp, &
"") !! deuteron relative atomic mass
type(codata_constant_type), parameter, public :: DEUTERON_RMS_CHARGE_RADIUS = &
codata_constant_type("deuteron rms charge radius", &
2.12778e-15_dp, 0.00027e-15_dp, &
"m") !! deuteron rms charge radius
type(codata_constant_type), parameter, public :: ELECTRON_CHARGE_TO_MASS_QUOTIENT = &
codata_constant_type("electron charge to mass quotient", &
-1.75882000838e11_dp, 0.00000000055e11_dp, &
"C kg^-1") !! electron charge to mass quotient
type(codata_constant_type), parameter, public :: ELECTRON_DEUTERON_MAG_MOM_RATIO = &
codata_constant_type("electron-deuteron mag. mom. ratio", &
-2143.9234921_dp, 0.0000056_dp, &
"") !! electron-deuteron mag. mom. ratio
type(codata_constant_type), parameter, public :: ELECTRON_DEUTERON_MASS_RATIO = &
codata_constant_type("electron-deuteron mass ratio", &
2.724437107629e-4_dp, 0.000000000047e-4_dp, &
"") !! electron-deuteron mass ratio
type(codata_constant_type), parameter, public :: ELECTRON_G_FACTOR = &
codata_constant_type("electron g factor", &
-2.00231930436092_dp, 0.00000000000036_dp, &
"") !! electron g factor
type(codata_constant_type), parameter, public :: ELECTRON_GYROMAG_RATIO = &
codata_constant_type("electron gyromag. ratio", &
1.76085962784e11_dp, 0.00000000055e11_dp, &
"s^-1 T^-1") !! electron gyromag. ratio
type(codata_constant_type), parameter, public :: ELECTRON_GYROMAG_RATIO_IN_MHZ_T = &
codata_constant_type("electron gyromag. ratio in MHz/T", &
28024.9513861_dp, 0.0000087_dp, &
"MHz T^-1") !! electron gyromag. ratio in MHz/T
type(codata_constant_type), parameter, public :: ELECTRON_HELION_MASS_RATIO = &
codata_constant_type("electron-helion mass ratio", &
1.819543074649e-4_dp, 0.000000000053e-4_dp, &
"") !! electron-helion mass ratio
type(codata_constant_type), parameter, public :: ELECTRON_MAG_MOM = &
codata_constant_type("electron mag. mom.", &
-9.2847646917e-24_dp, 0.0000000029e-24_dp, &
"J T^-1") !! electron mag. mom.
type(codata_constant_type), parameter, public :: ELECTRON_MAG_MOM_ANOMALY = &
codata_constant_type("electron mag. mom. anomaly", &
1.15965218046e-3_dp, 0.00000000018e-3_dp, &
"") !! electron mag. mom. anomaly
type(codata_constant_type), parameter, public :: ELECTRON_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("electron mag. mom. to Bohr magneton ratio", &
-1.00115965218046_dp, 0.00000000000018_dp, &
"") !! electron mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: ELECTRON_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("electron mag. mom. to nuclear magneton ratio", &
-1838.281971877_dp, 0.000000032_dp, &
"") !! electron mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: ELECTRON_MASS = &
codata_constant_type("electron mass", &
9.1093837139e-31_dp, 0.0000000028e-31_dp, &
"kg") !! electron mass
type(codata_constant_type), parameter, public :: ELECTRON_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("electron mass energy equivalent", &
8.1871057880e-14_dp, 0.0000000026e-14_dp, &
"J") !! electron mass energy equivalent
type(codata_constant_type), parameter, public :: ELECTRON_MASS_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("electron mass energy equivalent in MeV", &
0.51099895069_dp, 0.00000000016_dp, &
"MeV") !! electron mass energy equivalent in MeV
type(codata_constant_type), parameter, public :: ELECTRON_MASS_IN_U = &
codata_constant_type("electron mass in u", &
5.485799090441e-4_dp, 0.000000000097e-4_dp, &
"u") !! electron mass in u
type(codata_constant_type), parameter, public :: ELECTRON_MOLAR_MASS = &
codata_constant_type("electron molar mass", &
5.4857990962e-7_dp, 0.0000000017e-7_dp, &
"kg mol^-1") !! electron molar mass
type(codata_constant_type), parameter, public :: ELECTRON_MUON_MAG_MOM_RATIO = &
codata_constant_type("electron-muon mag. mom. ratio", &
206.7669881_dp, 0.0000046_dp, &
"") !! electron-muon mag. mom. ratio
type(codata_constant_type), parameter, public :: ELECTRON_MUON_MASS_RATIO = &
codata_constant_type("electron-muon mass ratio", &
4.83633170e-3_dp, 0.00000011e-3_dp, &
"") !! electron-muon mass ratio
type(codata_constant_type), parameter, public :: ELECTRON_NEUTRON_MAG_MOM_RATIO = &
codata_constant_type("electron-neutron mag. mom. ratio", &
960.92048_dp, 0.00023_dp, &
"") !! electron-neutron mag. mom. ratio
type(codata_constant_type), parameter, public :: ELECTRON_NEUTRON_MASS_RATIO = &
codata_constant_type("electron-neutron mass ratio", &
5.4386734416e-4_dp, 0.0000000022e-4_dp, &
"") !! electron-neutron mass ratio
type(codata_constant_type), parameter, public :: ELECTRON_PROTON_MAG_MOM_RATIO = &
codata_constant_type("electron-proton mag. mom. ratio", &
-658.21068789_dp, 0.00000019_dp, &
"") !! electron-proton mag. mom. ratio
type(codata_constant_type), parameter, public :: ELECTRON_PROTON_MASS_RATIO = &
codata_constant_type("electron-proton mass ratio", &
5.446170214889e-4_dp, 0.000000000094e-4_dp, &
"") !! electron-proton mass ratio
type(codata_constant_type), parameter, public :: ELECTRON_RELATIVE_ATOMIC_MASS = &
codata_constant_type("electron relative atomic mass", &
5.485799090441e-4_dp, 0.000000000097e-4_dp, &
"") !! electron relative atomic mass
type(codata_constant_type), parameter, public :: ELECTRON_TAU_MASS_RATIO = &
codata_constant_type("electron-tau mass ratio", &
2.87585e-4_dp, 0.00019e-4_dp, &
"") !! electron-tau mass ratio
type(codata_constant_type), parameter, public :: ELECTRON_TO_ALPHA_PARTICLE_MASS_RATIO = &
codata_constant_type("electron to alpha particle mass ratio", &
1.370933554733e-4_dp, 0.000000000032e-4_dp, &
"") !! electron to alpha particle mass ratio
type(codata_constant_type), parameter, public :: ELECTRON_TO_SHIELDED_HELION_MAG_MOM_RATIO = &
codata_constant_type("electron to shielded helion mag. mom. ratio", &
864.05823986_dp, 0.00000070_dp, &
"") !! electron to shielded helion mag. mom. ratio
type(codata_constant_type), parameter, public :: ELECTRON_TO_SHIELDED_PROTON_MAG_MOM_RATIO = &
codata_constant_type("electron to shielded proton mag. mom. ratio", &
-658.2275856_dp, 0.0000027_dp, &
"") !! electron to shielded proton mag. mom. ratio
type(codata_constant_type), parameter, public :: ELECTRON_TRITON_MASS_RATIO = &
codata_constant_type("electron-triton mass ratio", &
1.819200062327e-4_dp, 0.000000000068e-4_dp, &
"") !! electron-triton mass ratio
type(codata_constant_type), parameter, public :: ELECTRON_VOLT = &
codata_constant_type("electron volt", &
1.602176634e-19_dp, 0.0_dp, &
"J") !! electron volt
type(codata_constant_type), parameter, public :: ELECTRON_VOLT_ATOMIC_MASS_UNIT_RELATIONSHIP = &
codata_constant_type("electron volt-atomic mass unit relationship", &
1.07354410083e-9_dp, 0.00000000033e-9_dp, &
"u") !! electron volt-atomic mass unit relationship
type(codata_constant_type), parameter, public :: ELECTRON_VOLT_HARTREE_RELATIONSHIP = &
codata_constant_type("electron volt-hartree relationship", &
3.6749322175665e-2_dp, 0.0000000000040e-2_dp, &
"E_h") !! electron volt-hartree relationship
type(codata_constant_type), parameter, public :: ELECTRON_VOLT_HERTZ_RELATIONSHIP = &
codata_constant_type("electron volt-hertz relationship", &
2.417989242e14_dp, 0.0_dp, &
"Hz") !! electron volt-hertz relationship
type(codata_constant_type), parameter, public :: ELECTRON_VOLT_INVERSE_METER_RELATIONSHIP = &
codata_constant_type("electron volt-inverse meter relationship", &
8.065543937e5_dp, 0.0_dp, &
"m^-1") !! electron volt-inverse meter relationship
type(codata_constant_type), parameter, public :: ELECTRON_VOLT_JOULE_RELATIONSHIP = &
codata_constant_type("electron volt-joule relationship", &
1.602176634e-19_dp, 0.0_dp, &
"J") !! electron volt-joule relationship
type(codata_constant_type), parameter, public :: ELECTRON_VOLT_KELVIN_RELATIONSHIP = &
codata_constant_type("electron volt-kelvin relationship", &
1.160451812e4_dp, 0.0_dp, &
"K") !! electron volt-kelvin relationship
type(codata_constant_type), parameter, public :: ELECTRON_VOLT_KILOGRAM_RELATIONSHIP = &
codata_constant_type("electron volt-kilogram relationship", &
1.782661921e-36_dp, 0.0_dp, &
"kg") !! electron volt-kilogram relationship
type(codata_constant_type), parameter, public :: ELEMENTARY_CHARGE = &
codata_constant_type("elementary charge", &
1.602176634e-19_dp, 0.0_dp, &
"C") !! elementary charge
type(codata_constant_type), parameter, public :: ELEMENTARY_CHARGE_OVER_H_BAR = &
codata_constant_type("elementary charge over h-bar", &
1.519267447e15_dp, 0.0_dp, &
"A J^-1") !! elementary charge over h-bar
type(codata_constant_type), parameter, public :: FARADAY_CONSTANT = &
codata_constant_type("Faraday constant", &
96485.33212_dp, 0.0_dp, &
"C mol^-1") !! Faraday constant
type(codata_constant_type), parameter, public :: FERMI_COUPLING_CONSTANT = &
codata_constant_type("Fermi coupling constant", &
1.1663787e-5_dp, 0.0000006e-5_dp, &
"GeV^-2") !! Fermi coupling constant
type(codata_constant_type), parameter, public :: FINE_STRUCTURE_CONSTANT = &
codata_constant_type("fine-structure constant", &
7.2973525643e-3_dp, 0.0000000011e-3_dp, &
"") !! fine-structure constant
type(codata_constant_type), parameter, public :: FIRST_RADIATION_CONSTANT = &
codata_constant_type("first radiation constant", &
3.741771852e-16_dp, 0.0_dp, &
"W m^2") !! first radiation constant
type(codata_constant_type), parameter, public :: FIRST_RADIATION_CONSTANT_FOR_SPECTRAL_RADIANCE = &
codata_constant_type("first radiation constant for spectral radiance", &
1.191042972e-16_dp, 0.0_dp, &
"W m^2 sr^-1") !! first radiation constant for spectral radiance
type(codata_constant_type), parameter, public :: HARTREE_ATOMIC_MASS_UNIT_RELATIONSHIP = &
codata_constant_type("hartree-atomic mass unit relationship", &
2.92126231797e-8_dp, 0.00000000091e-8_dp, &
"u") !! hartree-atomic mass unit relationship
type(codata_constant_type), parameter, public :: HARTREE_ELECTRON_VOLT_RELATIONSHIP = &
codata_constant_type("hartree-electron volt relationship", &
27.211386245981_dp, 0.000000000030_dp, &
"eV") !! hartree-electron volt relationship
type(codata_constant_type), parameter, public :: HARTREE_ENERGY = &
codata_constant_type("Hartree energy", &
4.3597447222060e-18_dp, 0.0000000000048e-18_dp, &
"J") !! Hartree energy
type(codata_constant_type), parameter, public :: HARTREE_ENERGY_IN_EV = &
codata_constant_type("Hartree energy in eV", &
27.211386245981_dp, 0.000000000030_dp, &
"eV") !! Hartree energy in eV
type(codata_constant_type), parameter, public :: HARTREE_HERTZ_RELATIONSHIP = &
codata_constant_type("hartree-hertz relationship", &
6.5796839204999e15_dp, 0.0000000000072e15_dp, &
"Hz") !! hartree-hertz relationship
type(codata_constant_type), parameter, public :: HARTREE_INVERSE_METER_RELATIONSHIP = &
codata_constant_type("hartree-inverse meter relationship", &
2.1947463136314e7_dp, 0.0000000000024e7_dp, &
"m^-1") !! hartree-inverse meter relationship
type(codata_constant_type), parameter, public :: HARTREE_JOULE_RELATIONSHIP = &
codata_constant_type("hartree-joule relationship", &
4.3597447222060e-18_dp, 0.0000000000048e-18_dp, &
"J") !! hartree-joule relationship
type(codata_constant_type), parameter, public :: HARTREE_KELVIN_RELATIONSHIP = &
codata_constant_type("hartree-kelvin relationship", &
3.1577502480398e5_dp, 0.0000000000034e5_dp, &
"K") !! hartree-kelvin relationship
type(codata_constant_type), parameter, public :: HARTREE_KILOGRAM_RELATIONSHIP = &
codata_constant_type("hartree-kilogram relationship", &
4.8508702095419e-35_dp, 0.0000000000053e-35_dp, &
"kg") !! hartree-kilogram relationship
type(codata_constant_type), parameter, public :: HELION_ELECTRON_MASS_RATIO = &
codata_constant_type("helion-electron mass ratio", &
5495.88527984_dp, 0.00000016_dp, &
"") !! helion-electron mass ratio
type(codata_constant_type), parameter, public :: HELION_G_FACTOR = &
codata_constant_type("helion g factor", &
-4.2552506995_dp, 0.0000000034_dp, &
"") !! helion g factor
type(codata_constant_type), parameter, public :: HELION_MAG_MOM = &
codata_constant_type("helion mag. mom.", &
-1.07461755198e-26_dp, 0.00000000093e-26_dp, &
"J T^-1") !! helion mag. mom.
type(codata_constant_type), parameter, public :: HELION_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("helion mag. mom. to Bohr magneton ratio", &
-1.15874098083e-3_dp, 0.00000000094e-3_dp, &
"") !! helion mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: HELION_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("helion mag. mom. to nuclear magneton ratio", &
-2.1276253498_dp, 0.0000000017_dp, &
"") !! helion mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: HELION_MASS = &
codata_constant_type("helion mass", &
5.0064127862e-27_dp, 0.0000000016e-27_dp, &
"kg") !! helion mass
type(codata_constant_type), parameter, public :: HELION_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("helion mass energy equivalent", &
4.4995394185e-10_dp, 0.0000000014e-10_dp, &
"J") !! helion mass energy equivalent
type(codata_constant_type), parameter, public :: HELION_MASS_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("helion mass energy equivalent in MeV", &
2808.39161112_dp, 0.00000088_dp, &
"MeV") !! helion mass energy equivalent in MeV
type(codata_constant_type), parameter, public :: HELION_MASS_IN_U = &
codata_constant_type("helion mass in u", &
3.014932246932_dp, 0.000000000074_dp, &
"u") !! helion mass in u
type(codata_constant_type), parameter, public :: HELION_MOLAR_MASS = &
codata_constant_type("helion molar mass", &
3.01493225010e-3_dp, 0.00000000094e-3_dp, &
"kg mol^-1") !! helion molar mass
type(codata_constant_type), parameter, public :: HELION_PROTON_MASS_RATIO = &
codata_constant_type("helion-proton mass ratio", &
2.993152671552_dp, 0.000000000070_dp, &
"") !! helion-proton mass ratio
type(codata_constant_type), parameter, public :: HELION_RELATIVE_ATOMIC_MASS = &
codata_constant_type("helion relative atomic mass", &
3.014932246932_dp, 0.000000000074_dp, &
"") !! helion relative atomic mass
type(codata_constant_type), parameter, public :: HELION_SHIELDING_SHIFT = &
codata_constant_type("helion shielding shift", &
5.9967029e-5_dp, 0.0000023e-5_dp, &
"") !! helion shielding shift
type(codata_constant_type), parameter, public :: HERTZ_ATOMIC_MASS_UNIT_RELATIONSHIP = &
codata_constant_type("hertz-atomic mass unit relationship", &
4.4398216590e-24_dp, 0.0000000014e-24_dp, &
"u") !! hertz-atomic mass unit relationship
type(codata_constant_type), parameter, public :: HERTZ_ELECTRON_VOLT_RELATIONSHIP = &
codata_constant_type("hertz-electron volt relationship", &
4.135667696e-15_dp, 0.0_dp, &
"eV") !! hertz-electron volt relationship
type(codata_constant_type), parameter, public :: HERTZ_HARTREE_RELATIONSHIP = &
codata_constant_type("hertz-hartree relationship", &
1.5198298460574e-16_dp, 0.0000000000017e-16_dp, &
"E_h") !! hertz-hartree relationship
type(codata_constant_type), parameter, public :: HERTZ_INVERSE_METER_RELATIONSHIP = &
codata_constant_type("hertz-inverse meter relationship", &
3.335640951e-9_dp, 0.0_dp, &
"m^-1") !! hertz-inverse meter relationship
type(codata_constant_type), parameter, public :: HERTZ_JOULE_RELATIONSHIP = &
codata_constant_type("hertz-joule relationship", &
6.62607015e-34_dp, 0.0_dp, &
"J") !! hertz-joule relationship
type(codata_constant_type), parameter, public :: HERTZ_KELVIN_RELATIONSHIP = &
codata_constant_type("hertz-kelvin relationship", &
4.799243073e-11_dp, 0.0_dp, &
"K") !! hertz-kelvin relationship
type(codata_constant_type), parameter, public :: HERTZ_KILOGRAM_RELATIONSHIP = &
codata_constant_type("hertz-kilogram relationship", &
7.372497323e-51_dp, 0.0_dp, &
"kg") !! hertz-kilogram relationship
type(codata_constant_type), parameter, public :: HYPERFINE_TRANSITION_FREQUENCY_OF_CS_133 = &
codata_constant_type("hyperfine transition frequency of Cs-133", &
9192631770_dp, 0.0_dp, &
"Hz") !! hyperfine transition frequency of Cs-133
type(codata_constant_type), parameter, public :: INVERSE_FINE_STRUCTURE_CONSTANT = &
codata_constant_type("inverse fine-structure constant", &
137.035999177_dp, 0.000000021_dp, &
"") !! inverse fine-structure constant
type(codata_constant_type), parameter, public :: INVERSE_METER_ATOMIC_MASS_UNIT_RELATIONSHIP = &
codata_constant_type("inverse meter-atomic mass unit relationship", &
1.33102504824e-15_dp, 0.00000000041e-15_dp, &
"u") !! inverse meter-atomic mass unit relationship
type(codata_constant_type), parameter, public :: INVERSE_METER_ELECTRON_VOLT_RELATIONSHIP = &
codata_constant_type("inverse meter-electron volt relationship", &
1.239841984e-6_dp, 0.0_dp, &
"eV") !! inverse meter-electron volt relationship
type(codata_constant_type), parameter, public :: INVERSE_METER_HARTREE_RELATIONSHIP = &
codata_constant_type("inverse meter-hartree relationship", &
4.5563352529132e-8_dp, 0.0000000000050e-8_dp, &
"E_h") !! inverse meter-hartree relationship
type(codata_constant_type), parameter, public :: INVERSE_METER_HERTZ_RELATIONSHIP = &
codata_constant_type("inverse meter-hertz relationship", &
299792458_dp, 0.0_dp, &
"Hz") !! inverse meter-hertz relationship
type(codata_constant_type), parameter, public :: INVERSE_METER_JOULE_RELATIONSHIP = &
codata_constant_type("inverse meter-joule relationship", &
1.986445857e-25_dp, 0.0_dp, &
"J") !! inverse meter-joule relationship
type(codata_constant_type), parameter, public :: INVERSE_METER_KELVIN_RELATIONSHIP = &
codata_constant_type("inverse meter-kelvin relationship", &
1.438776877e-2_dp, 0.0_dp, &
"K") !! inverse meter-kelvin relationship
type(codata_constant_type), parameter, public :: INVERSE_METER_KILOGRAM_RELATIONSHIP = &
codata_constant_type("inverse meter-kilogram relationship", &
2.210219094e-42_dp, 0.0_dp, &
"kg") !! inverse meter-kilogram relationship
type(codata_constant_type), parameter, public :: INVERSE_OF_CONDUCTANCE_QUANTUM = &
codata_constant_type("inverse of conductance quantum", &
12906.40372_dp, 0.0_dp, &
"ohm") !! inverse of conductance quantum
type(codata_constant_type), parameter, public :: JOSEPHSON_CONSTANT = &
codata_constant_type("Josephson constant", &
483597.8484e9_dp, 0.0_dp, &
"Hz V^-1") !! Josephson constant
type(codata_constant_type), parameter, public :: JOULE_ATOMIC_MASS_UNIT_RELATIONSHIP = &
codata_constant_type("joule-atomic mass unit relationship", &
6.7005352471e9_dp, 0.0000000021e9_dp, &
"u") !! joule-atomic mass unit relationship
type(codata_constant_type), parameter, public :: JOULE_ELECTRON_VOLT_RELATIONSHIP = &
codata_constant_type("joule-electron volt relationship", &
6.241509074e18_dp, 0.0_dp, &
"eV") !! joule-electron volt relationship
type(codata_constant_type), parameter, public :: JOULE_HARTREE_RELATIONSHIP = &
codata_constant_type("joule-hartree relationship", &
2.2937122783969e17_dp, 0.0000000000025e17_dp, &
"E_h") !! joule-hartree relationship
type(codata_constant_type), parameter, public :: JOULE_HERTZ_RELATIONSHIP = &
codata_constant_type("joule-hertz relationship", &
1.509190179e33_dp, 0.0_dp, &
"Hz") !! joule-hertz relationship
type(codata_constant_type), parameter, public :: JOULE_INVERSE_METER_RELATIONSHIP = &
codata_constant_type("joule-inverse meter relationship", &
5.034116567e24_dp, 0.0_dp, &
"m^-1") !! joule-inverse meter relationship
type(codata_constant_type), parameter, public :: JOULE_KELVIN_RELATIONSHIP = &
codata_constant_type("joule-kelvin relationship", &
7.242970516e22_dp, 0.0_dp, &
"K") !! joule-kelvin relationship
type(codata_constant_type), parameter, public :: JOULE_KILOGRAM_RELATIONSHIP = &
codata_constant_type("joule-kilogram relationship", &
1.112650056e-17_dp, 0.0_dp, &
"kg") !! joule-kilogram relationship
type(codata_constant_type), parameter, public :: KELVIN_ATOMIC_MASS_UNIT_RELATIONSHIP = &
codata_constant_type("kelvin-atomic mass unit relationship", &
9.2510872884e-14_dp, 0.0000000029e-14_dp, &
"u") !! kelvin-atomic mass unit relationship
type(codata_constant_type), parameter, public :: KELVIN_ELECTRON_VOLT_RELATIONSHIP = &
codata_constant_type("kelvin-electron volt relationship", &
8.617333262e-5_dp, 0.0_dp, &
"eV") !! kelvin-electron volt relationship
type(codata_constant_type), parameter, public :: KELVIN_HARTREE_RELATIONSHIP = &
codata_constant_type("kelvin-hartree relationship", &
3.1668115634564e-6_dp, 0.0000000000035e-6_dp, &
"E_h") !! kelvin-hartree relationship
type(codata_constant_type), parameter, public :: KELVIN_HERTZ_RELATIONSHIP = &
codata_constant_type("kelvin-hertz relationship", &
2.083661912e10_dp, 0.0_dp, &
"Hz") !! kelvin-hertz relationship
type(codata_constant_type), parameter, public :: KELVIN_INVERSE_METER_RELATIONSHIP = &
codata_constant_type("kelvin-inverse meter relationship", &
69.50348004_dp, 0.0_dp, &
"m^-1") !! kelvin-inverse meter relationship
type(codata_constant_type), parameter, public :: KELVIN_JOULE_RELATIONSHIP = &
codata_constant_type("kelvin-joule relationship", &
1.380649e-23_dp, 0.0_dp, &
"J") !! kelvin-joule relationship
type(codata_constant_type), parameter, public :: KELVIN_KILOGRAM_RELATIONSHIP = &
codata_constant_type("kelvin-kilogram relationship", &
1.536179187e-40_dp, 0.0_dp, &
"kg") !! kelvin-kilogram relationship
type(codata_constant_type), parameter, public :: KILOGRAM_ATOMIC_MASS_UNIT_RELATIONSHIP = &
codata_constant_type("kilogram-atomic mass unit relationship", &
6.0221407537e26_dp, 0.0000000019e26_dp, &
"u") !! kilogram-atomic mass unit relationship
type(codata_constant_type), parameter, public :: KILOGRAM_ELECTRON_VOLT_RELATIONSHIP = &
codata_constant_type("kilogram-electron volt relationship", &
5.609588603e35_dp, 0.0_dp, &
"eV") !! kilogram-electron volt relationship
type(codata_constant_type), parameter, public :: KILOGRAM_HARTREE_RELATIONSHIP = &
codata_constant_type("kilogram-hartree relationship", &
2.0614857887415e34_dp, 0.0000000000022e34_dp, &
"E_h") !! kilogram-hartree relationship
type(codata_constant_type), parameter, public :: KILOGRAM_HERTZ_RELATIONSHIP = &
codata_constant_type("kilogram-hertz relationship", &
1.356392489e50_dp, 0.0_dp, &
"Hz") !! kilogram-hertz relationship
type(codata_constant_type), parameter, public :: KILOGRAM_INVERSE_METER_RELATIONSHIP = &
codata_constant_type("kilogram-inverse meter relationship", &
4.524438335e41_dp, 0.0_dp, &
"m^-1") !! kilogram-inverse meter relationship
type(codata_constant_type), parameter, public :: KILOGRAM_JOULE_RELATIONSHIP = &
codata_constant_type("kilogram-joule relationship", &
8.987551787e16_dp, 0.0_dp, &
"J") !! kilogram-joule relationship
type(codata_constant_type), parameter, public :: KILOGRAM_KELVIN_RELATIONSHIP = &
codata_constant_type("kilogram-kelvin relationship", &
6.509657260e39_dp, 0.0_dp, &
"K") !! kilogram-kelvin relationship
type(codata_constant_type), parameter, public :: LATTICE_PARAMETER_OF_SILICON = &
codata_constant_type("lattice parameter of silicon", &
5.431020511e-10_dp, 0.000000089e-10_dp, &
"m") !! lattice parameter of silicon
type(codata_constant_type), parameter, public :: LATTICE_SPACING_OF_IDEAL_SI_220 = &
codata_constant_type("lattice spacing of ideal Si (220)", &
1.920155716e-10_dp, 0.000000032e-10_dp, &
"m") !! lattice spacing of ideal Si (220)
type(codata_constant_type), parameter, public :: LOSCHMIDT_CONSTANT_273_15_K_100_KPA = &
codata_constant_type("Loschmidt constant (273.15 K, 100 kPa)", &
2.651645804e25_dp, 0.0_dp, &
"m^-3") !! Loschmidt constant (273.15 K, 100 kPa)
type(codata_constant_type), parameter, public :: LOSCHMIDT_CONSTANT_273_15_K_101_325_KPA = &
codata_constant_type("Loschmidt constant (273.15 K, 101.325 kPa)", &
2.686780111e25_dp, 0.0_dp, &
"m^-3") !! Loschmidt constant (273.15 K, 101.325 kPa)
type(codata_constant_type), parameter, public :: LUMINOUS_EFFICACY = &
codata_constant_type("luminous efficacy", &
683_dp, 0.0_dp, &
"lm W^-1") !! luminous efficacy
type(codata_constant_type), parameter, public :: MAG_FLUX_QUANTUM = &
codata_constant_type("mag. flux quantum", &
2.067833848e-15_dp, 0.0_dp, &
"Wb") !! mag. flux quantum
type(codata_constant_type), parameter, public :: MOLAR_GAS_CONSTANT = &
codata_constant_type("molar gas constant", &
8.314462618_dp, 0.0_dp, &
"J mol^-1 K^-1") !! molar gas constant
type(codata_constant_type), parameter, public :: MOLAR_MASS_CONSTANT = &
codata_constant_type("molar mass constant", &
1.00000000105e-3_dp, 0.00000000031e-3_dp, &
"kg mol^-1") !! molar mass constant
type(codata_constant_type), parameter, public :: MOLAR_MASS_OF_CARBON_12 = &
codata_constant_type("molar mass of carbon-12", &
12.0000000126e-3_dp, 0.0000000037e-3_dp, &
"kg mol^-1") !! molar mass of carbon-12
type(codata_constant_type), parameter, public :: MOLAR_PLANCK_CONSTANT = &
codata_constant_type("molar Planck constant", &
3.990312712e-10_dp, 0.0_dp, &
"J Hz^-1 mol^-1") !! molar Planck constant
type(codata_constant_type), parameter, public :: MOLAR_VOLUME_OF_IDEAL_GAS_273_15_K_100_KPA = &
codata_constant_type("molar volume of ideal gas (273.15 K, 100 kPa)", &
22.71095464e-3_dp, 0.0_dp, &
"m^3 mol^-1") !! molar volume of ideal gas (273.15 K, 100 kPa)
type(codata_constant_type), parameter, public :: MOLAR_VOLUME_OF_IDEAL_GAS_273_15_K_101_325_KPA = &
codata_constant_type("molar volume of ideal gas (273.15 K, 101.325 kPa)", &
22.41396954e-3_dp, 0.0_dp, &
"m^3 mol^-1") !! molar volume of ideal gas (273.15 K, 101.325 kPa)
type(codata_constant_type), parameter, public :: MOLAR_VOLUME_OF_SILICON = &
codata_constant_type("molar volume of silicon", &
1.205883199e-5_dp, 0.000000060e-5_dp, &
"m^3 mol^-1") !! molar volume of silicon
type(codata_constant_type), parameter, public :: MOLYBDENUM_X_UNIT = &
codata_constant_type("Molybdenum x unit", &
1.00209952e-13_dp, 0.00000053e-13_dp, &
"m") !! Molybdenum x unit
type(codata_constant_type), parameter, public :: MUON_COMPTON_WAVELENGTH = &
codata_constant_type("muon Compton wavelength", &
1.173444110e-14_dp, 0.000000026e-14_dp, &
"m") !! muon Compton wavelength
type(codata_constant_type), parameter, public :: MUON_ELECTRON_MASS_RATIO = &
codata_constant_type("muon-electron mass ratio", &
206.7682827_dp, 0.0000046_dp, &
"") !! muon-electron mass ratio
type(codata_constant_type), parameter, public :: MUON_G_FACTOR = &
codata_constant_type("muon g factor", &
-2.00233184123_dp, 0.00000000082_dp, &
"") !! muon g factor
type(codata_constant_type), parameter, public :: MUON_MAG_MOM = &
codata_constant_type("muon mag. mom.", &
-4.49044830e-26_dp, 0.00000010e-26_dp, &
"J T^-1") !! muon mag. mom.
type(codata_constant_type), parameter, public :: MUON_MAG_MOM_ANOMALY = &
codata_constant_type("muon mag. mom. anomaly", &
1.16592062e-3_dp, 0.00000041e-3_dp, &
"") !! muon mag. mom. anomaly
type(codata_constant_type), parameter, public :: MUON_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("muon mag. mom. to Bohr magneton ratio", &
-4.84197048e-3_dp, 0.00000011e-3_dp, &
"") !! muon mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: MUON_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("muon mag. mom. to nuclear magneton ratio", &
-8.89059704_dp, 0.00000020_dp, &
"") !! muon mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: MUON_MASS = &
codata_constant_type("muon mass", &
1.883531627e-28_dp, 0.000000042e-28_dp, &
"kg") !! muon mass
type(codata_constant_type), parameter, public :: MUON_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("muon mass energy equivalent", &
1.692833804e-11_dp, 0.000000038e-11_dp, &
"J") !! muon mass energy equivalent
type(codata_constant_type), parameter, public :: MUON_MASS_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("muon mass energy equivalent in MeV", &
105.6583755_dp, 0.0000023_dp, &
"MeV") !! muon mass energy equivalent in MeV
type(codata_constant_type), parameter, public :: MUON_MASS_IN_U = &
codata_constant_type("muon mass in u", &
0.1134289257_dp, 0.0000000025_dp, &
"u") !! muon mass in u
type(codata_constant_type), parameter, public :: MUON_MOLAR_MASS = &
codata_constant_type("muon molar mass", &
1.134289258e-4_dp, 0.000000025e-4_dp, &
"kg mol^-1") !! muon molar mass
type(codata_constant_type), parameter, public :: MUON_NEUTRON_MASS_RATIO = &
codata_constant_type("muon-neutron mass ratio", &
0.1124545168_dp, 0.0000000025_dp, &
"") !! muon-neutron mass ratio
type(codata_constant_type), parameter, public :: MUON_PROTON_MAG_MOM_RATIO = &
codata_constant_type("muon-proton mag. mom. ratio", &
-3.183345146_dp, 0.000000071_dp, &
"") !! muon-proton mag. mom. ratio
type(codata_constant_type), parameter, public :: MUON_PROTON_MASS_RATIO = &
codata_constant_type("muon-proton mass ratio", &
0.1126095262_dp, 0.0000000025_dp, &
"") !! muon-proton mass ratio
type(codata_constant_type), parameter, public :: MUON_TAU_MASS_RATIO = &
codata_constant_type("muon-tau mass ratio", &
5.94635e-2_dp, 0.00040e-2_dp, &
"") !! muon-tau mass ratio
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_ACTION = &
codata_constant_type("natural unit of action", &
1.054571817e-34_dp, 0.0_dp, &
"J s") !! natural unit of action
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_ACTION_IN_EV_S = &
codata_constant_type("natural unit of action in eV s", &
6.582119569e-16_dp, 0.0_dp, &
"eV s") !! natural unit of action in eV s
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_ENERGY = &
codata_constant_type("natural unit of energy", &
8.1871057880e-14_dp, 0.0000000026e-14_dp, &
"J") !! natural unit of energy
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_ENERGY_IN_MEV = &
codata_constant_type("natural unit of energy in MeV", &
0.51099895069_dp, 0.00000000016_dp, &
"MeV") !! natural unit of energy in MeV
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_LENGTH = &
codata_constant_type("natural unit of length", &
3.8615926744e-13_dp, 0.0000000012e-13_dp, &
"m") !! natural unit of length
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_MASS = &
codata_constant_type("natural unit of mass", &
9.1093837139e-31_dp, 0.0000000028e-31_dp, &
"kg") !! natural unit of mass
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_MOMENTUM = &
codata_constant_type("natural unit of momentum", &
2.73092453446e-22_dp, 0.00000000085e-22_dp, &
"kg m s^-1") !! natural unit of momentum
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_MOMENTUM_IN_MEV_C = &
codata_constant_type("natural unit of momentum in MeV/c", &
0.51099895069_dp, 0.00000000016_dp, &
"MeV/c") !! natural unit of momentum in MeV/c
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_TIME = &
codata_constant_type("natural unit of time", &
1.28808866644e-21_dp, 0.00000000040e-21_dp, &
"s") !! natural unit of time
type(codata_constant_type), parameter, public :: NATURAL_UNIT_OF_VELOCITY = &
codata_constant_type("natural unit of velocity", &
299792458_dp, 0.0_dp, &
"m s^-1") !! natural unit of velocity
type(codata_constant_type), parameter, public :: NEUTRON_COMPTON_WAVELENGTH = &
codata_constant_type("neutron Compton wavelength", &
1.31959090382e-15_dp, 0.00000000067e-15_dp, &
"m") !! neutron Compton wavelength
type(codata_constant_type), parameter, public :: NEUTRON_ELECTRON_MAG_MOM_RATIO = &
codata_constant_type("neutron-electron mag. mom. ratio", &
1.04066884e-3_dp, 0.00000024e-3_dp, &
"") !! neutron-electron mag. mom. ratio
type(codata_constant_type), parameter, public :: NEUTRON_ELECTRON_MASS_RATIO = &
codata_constant_type("neutron-electron mass ratio", &
1838.68366200_dp, 0.00000074_dp, &
"") !! neutron-electron mass ratio
type(codata_constant_type), parameter, public :: NEUTRON_G_FACTOR = &
codata_constant_type("neutron g factor", &
-3.82608552_dp, 0.00000090_dp, &
"") !! neutron g factor
type(codata_constant_type), parameter, public :: NEUTRON_GYROMAG_RATIO = &
codata_constant_type("neutron gyromag. ratio", &
1.83247174e8_dp, 0.00000043e8_dp, &
"s^-1 T^-1") !! neutron gyromag. ratio
type(codata_constant_type), parameter, public :: NEUTRON_GYROMAG_RATIO_IN_MHZ_T = &
codata_constant_type("neutron gyromag. ratio in MHz/T", &
29.1646935_dp, 0.0000069_dp, &
"MHz T^-1") !! neutron gyromag. ratio in MHz/T
type(codata_constant_type), parameter, public :: NEUTRON_MAG_MOM = &
codata_constant_type("neutron mag. mom.", &
-9.6623653e-27_dp, 0.0000023e-27_dp, &
"J T^-1") !! neutron mag. mom.
type(codata_constant_type), parameter, public :: NEUTRON_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("neutron mag. mom. to Bohr magneton ratio", &
-1.04187565e-3_dp, 0.00000025e-3_dp, &
"") !! neutron mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: NEUTRON_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("neutron mag. mom. to nuclear magneton ratio", &
-1.91304276_dp, 0.00000045_dp, &
"") !! neutron mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: NEUTRON_MASS = &
codata_constant_type("neutron mass", &
1.67492750056e-27_dp, 0.00000000085e-27_dp, &
"kg") !! neutron mass
type(codata_constant_type), parameter, public :: NEUTRON_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("neutron mass energy equivalent", &
1.50534976514e-10_dp, 0.00000000076e-10_dp, &
"J") !! neutron mass energy equivalent
type(codata_constant_type), parameter, public :: NEUTRON_MASS_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("neutron mass energy equivalent in MeV", &
939.56542194_dp, 0.00000048_dp, &
"MeV") !! neutron mass energy equivalent in MeV
type(codata_constant_type), parameter, public :: NEUTRON_MASS_IN_U = &
codata_constant_type("neutron mass in u", &
1.00866491606_dp, 0.00000000040_dp, &
"u") !! neutron mass in u
type(codata_constant_type), parameter, public :: NEUTRON_MOLAR_MASS = &
codata_constant_type("neutron molar mass", &
1.00866491712e-3_dp, 0.00000000051e-3_dp, &
"kg mol^-1") !! neutron molar mass
type(codata_constant_type), parameter, public :: NEUTRON_MUON_MASS_RATIO = &
codata_constant_type("neutron-muon mass ratio", &
8.89248408_dp, 0.00000020_dp, &
"") !! neutron-muon mass ratio
type(codata_constant_type), parameter, public :: NEUTRON_PROTON_MAG_MOM_RATIO = &
codata_constant_type("neutron-proton mag. mom. ratio", &
-0.68497935_dp, 0.00000016_dp, &
"") !! neutron-proton mag. mom. ratio
type(codata_constant_type), parameter, public :: NEUTRON_PROTON_MASS_DIFFERENCE = &
codata_constant_type("neutron-proton mass difference", &
2.30557461e-30_dp, 0.00000067e-30_dp, &
"kg") !! neutron-proton mass difference
type(codata_constant_type), parameter, public :: NEUTRON_PROTON_MASS_DIFFERENCE_ENERGY_EQUIVALENT = &
codata_constant_type("neutron-proton mass difference energy equivalent", &
2.07214712e-13_dp, 0.00000060e-13_dp, &
"J") !! neutron-proton mass difference energy equivalent
type(codata_constant_type), parameter, public :: NEUTRON_PROTON_MASS_DIFFERENCE_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("neutron-proton mass difference energy equivalent in MeV", &
1.29333251_dp, 0.00000038_dp, &
"MeV") !! neutron-proton mass difference energy equivalent in MeV
type(codata_constant_type), parameter, public :: NEUTRON_PROTON_MASS_DIFFERENCE_IN_U = &
codata_constant_type("neutron-proton mass difference in u", &
1.38844948e-3_dp, 0.00000040e-3_dp, &
"u") !! neutron-proton mass difference in u
type(codata_constant_type), parameter, public :: NEUTRON_PROTON_MASS_RATIO = &
codata_constant_type("neutron-proton mass ratio", &
1.00137841946_dp, 0.00000000040_dp, &
"") !! neutron-proton mass ratio
type(codata_constant_type), parameter, public :: NEUTRON_RELATIVE_ATOMIC_MASS = &
codata_constant_type("neutron relative atomic mass", &
1.00866491606_dp, 0.00000000040_dp, &
"") !! neutron relative atomic mass
type(codata_constant_type), parameter, public :: NEUTRON_TAU_MASS_RATIO = &
codata_constant_type("neutron-tau mass ratio", &
0.528779_dp, 0.000036_dp, &
"") !! neutron-tau mass ratio
type(codata_constant_type), parameter, public :: NEUTRON_TO_SHIELDED_PROTON_MAG_MOM_RATIO = &
codata_constant_type("neutron to shielded proton mag. mom. ratio", &
-0.68499694_dp, 0.00000016_dp, &
"") !! neutron to shielded proton mag. mom. ratio
type(codata_constant_type), parameter, public :: NEWTONIAN_CONSTANT_OF_GRAVITATION = &
codata_constant_type("Newtonian constant of gravitation", &
6.67430e-11_dp, 0.00015e-11_dp, &
"m^3 kg^-1 s^-2") !! Newtonian constant of gravitation
type(codata_constant_type), parameter, public :: NEWTONIAN_CONSTANT_OF_GRAVITATION_OVER_H_BAR_C = &
codata_constant_type("Newtonian constant of gravitation over h-bar c", &
6.70883e-39_dp, 0.00015e-39_dp, &
"(GeV/c^2)^-2") !! Newtonian constant of gravitation over h-bar c
type(codata_constant_type), parameter, public :: NUCLEAR_MAGNETON = &
codata_constant_type("nuclear magneton", &
5.0507837393e-27_dp, 0.0000000016e-27_dp, &
"J T^-1") !! nuclear magneton
type(codata_constant_type), parameter, public :: NUCLEAR_MAGNETON_IN_EV_T = &
codata_constant_type("nuclear magneton in eV/T", &
3.15245125417e-8_dp, 0.00000000098e-8_dp, &
"eV T^-1") !! nuclear magneton in eV/T
type(codata_constant_type), parameter, public :: NUCLEAR_MAGNETON_IN_INVERSE_METER_PER_TESLA = &
codata_constant_type("nuclear magneton in inverse meter per tesla", &
2.54262341009e-2_dp, 0.00000000079e-2_dp, &
"m^-1 T^-1") !! nuclear magneton in inverse meter per tesla
type(codata_constant_type), parameter, public :: NUCLEAR_MAGNETON_IN_K_T = &
codata_constant_type("nuclear magneton in K/T", &
3.6582677706e-4_dp, 0.0000000011e-4_dp, &
"K T^-1") !! nuclear magneton in K/T
type(codata_constant_type), parameter, public :: NUCLEAR_MAGNETON_IN_MHZ_T = &
codata_constant_type("nuclear magneton in MHz/T", &
7.6225932188_dp, 0.0000000024_dp, &
"MHz T^-1") !! nuclear magneton in MHz/T
type(codata_constant_type), parameter, public :: PLANCK_CONSTANT = &
codata_constant_type("Planck constant", &
6.62607015e-34_dp, 0.0_dp, &
"J Hz^-1") !! Planck constant
type(codata_constant_type), parameter, public :: PLANCK_CONSTANT_IN_EV_HZ = &
codata_constant_type("Planck constant in eV/Hz", &
4.135667696e-15_dp, 0.0_dp, &
"eV Hz^-1") !! Planck constant in eV/Hz
type(codata_constant_type), parameter, public :: PLANCK_LENGTH = &
codata_constant_type("Planck length", &
1.616255e-35_dp, 0.000018e-35_dp, &
"m") !! Planck length
type(codata_constant_type), parameter, public :: PLANCK_MASS = &
codata_constant_type("Planck mass", &
2.176434e-8_dp, 0.000024e-8_dp, &
"kg") !! Planck mass
type(codata_constant_type), parameter, public :: PLANCK_MASS_ENERGY_EQUIVALENT_IN_GEV = &
codata_constant_type("Planck mass energy equivalent in GeV", &
1.220890e19_dp, 0.000014e19_dp, &
"GeV") !! Planck mass energy equivalent in GeV
type(codata_constant_type), parameter, public :: PLANCK_TEMPERATURE = &
codata_constant_type("Planck temperature", &
1.416784e32_dp, 0.000016e32_dp, &
"K") !! Planck temperature
type(codata_constant_type), parameter, public :: PLANCK_TIME = &
codata_constant_type("Planck time", &
5.391247e-44_dp, 0.000060e-44_dp, &
"s") !! Planck time
type(codata_constant_type), parameter, public :: PROTON_CHARGE_TO_MASS_QUOTIENT = &
codata_constant_type("proton charge to mass quotient", &
9.5788331430e7_dp, 0.0000000030e7_dp, &
"C kg^-1") !! proton charge to mass quotient
type(codata_constant_type), parameter, public :: PROTON_COMPTON_WAVELENGTH = &
codata_constant_type("proton Compton wavelength", &
1.32140985360e-15_dp, 0.00000000041e-15_dp, &
"m") !! proton Compton wavelength
type(codata_constant_type), parameter, public :: PROTON_ELECTRON_MASS_RATIO = &
codata_constant_type("proton-electron mass ratio", &
1836.152673426_dp, 0.000000032_dp, &
"") !! proton-electron mass ratio
type(codata_constant_type), parameter, public :: PROTON_G_FACTOR = &
codata_constant_type("proton g factor", &
5.5856946893_dp, 0.0000000016_dp, &
"") !! proton g factor
type(codata_constant_type), parameter, public :: PROTON_GYROMAG_RATIO = &
codata_constant_type("proton gyromag. ratio", &
2.6752218708e8_dp, 0.0000000011e8_dp, &
"s^-1 T^-1") !! proton gyromag. ratio
type(codata_constant_type), parameter, public :: PROTON_GYROMAG_RATIO_IN_MHZ_T = &
codata_constant_type("proton gyromag. ratio in MHz/T", &
42.577478461_dp, 0.000000018_dp, &
"MHz T^-1") !! proton gyromag. ratio in MHz/T
type(codata_constant_type), parameter, public :: PROTON_MAG_MOM = &
codata_constant_type("proton mag. mom.", &
1.41060679545e-26_dp, 0.00000000060e-26_dp, &
"J T^-1") !! proton mag. mom.
type(codata_constant_type), parameter, public :: PROTON_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("proton mag. mom. to Bohr magneton ratio", &
1.52103220230e-3_dp, 0.00000000045e-3_dp, &
"") !! proton mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: PROTON_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("proton mag. mom. to nuclear magneton ratio", &
2.79284734463_dp, 0.00000000082_dp, &
"") !! proton mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: PROTON_MAG_SHIELDING_CORRECTION = &
codata_constant_type("proton mag. shielding correction", &
2.56715e-5_dp, 0.00041e-5_dp, &
"") !! proton mag. shielding correction
type(codata_constant_type), parameter, public :: PROTON_MASS = &
codata_constant_type("proton mass", &
1.67262192595e-27_dp, 0.00000000052e-27_dp, &
"kg") !! proton mass
type(codata_constant_type), parameter, public :: PROTON_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("proton mass energy equivalent", &
1.50327761802e-10_dp, 0.00000000047e-10_dp, &
"J") !! proton mass energy equivalent
type(codata_constant_type), parameter, public :: PROTON_MASS_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("proton mass energy equivalent in MeV", &
938.27208943_dp, 0.00000029_dp, &
"MeV") !! proton mass energy equivalent in MeV
type(codata_constant_type), parameter, public :: PROTON_MASS_IN_U = &
codata_constant_type("proton mass in u", &
1.0072764665789_dp, 0.0000000000083_dp, &
"u") !! proton mass in u
type(codata_constant_type), parameter, public :: PROTON_MOLAR_MASS = &
codata_constant_type("proton molar mass", &
1.00727646764e-3_dp, 0.00000000031e-3_dp, &
"kg mol^-1") !! proton molar mass
type(codata_constant_type), parameter, public :: PROTON_MUON_MASS_RATIO = &
codata_constant_type("proton-muon mass ratio", &
8.88024338_dp, 0.00000020_dp, &
"") !! proton-muon mass ratio
type(codata_constant_type), parameter, public :: PROTON_NEUTRON_MAG_MOM_RATIO = &
codata_constant_type("proton-neutron mag. mom. ratio", &
-1.45989802_dp, 0.00000034_dp, &
"") !! proton-neutron mag. mom. ratio
type(codata_constant_type), parameter, public :: PROTON_NEUTRON_MASS_RATIO = &
codata_constant_type("proton-neutron mass ratio", &
0.99862347797_dp, 0.00000000040_dp, &
"") !! proton-neutron mass ratio
type(codata_constant_type), parameter, public :: PROTON_RELATIVE_ATOMIC_MASS = &
codata_constant_type("proton relative atomic mass", &
1.0072764665789_dp, 0.0000000000083_dp, &
"") !! proton relative atomic mass
type(codata_constant_type), parameter, public :: PROTON_RMS_CHARGE_RADIUS = &
codata_constant_type("proton rms charge radius", &
8.4075e-16_dp, 0.0064e-16_dp, &
"m") !! proton rms charge radius
type(codata_constant_type), parameter, public :: PROTON_TAU_MASS_RATIO = &
codata_constant_type("proton-tau mass ratio", &
0.528051_dp, 0.000036_dp, &
"") !! proton-tau mass ratio
type(codata_constant_type), parameter, public :: QUANTUM_OF_CIRCULATION = &
codata_constant_type("quantum of circulation", &
3.6369475467e-4_dp, 0.0000000011e-4_dp, &
"m^2 s^-1") !! quantum of circulation
type(codata_constant_type), parameter, public :: QUANTUM_OF_CIRCULATION_TIMES_2 = &
codata_constant_type("quantum of circulation times 2", &
7.2738950934e-4_dp, 0.0000000023e-4_dp, &
"m^2 s^-1") !! quantum of circulation times 2
type(codata_constant_type), parameter, public :: REDUCED_COMPTON_WAVELENGTH = &
codata_constant_type("reduced Compton wavelength", &
3.8615926744e-13_dp, 0.0000000012e-13_dp, &
"m") !! reduced Compton wavelength
type(codata_constant_type), parameter, public :: REDUCED_MUON_COMPTON_WAVELENGTH = &
codata_constant_type("reduced muon Compton wavelength", &
1.867594306e-15_dp, 0.000000042e-15_dp, &
"m") !! reduced muon Compton wavelength
type(codata_constant_type), parameter, public :: REDUCED_NEUTRON_COMPTON_WAVELENGTH = &
codata_constant_type("reduced neutron Compton wavelength", &
2.1001941520e-16_dp, 0.0000000011e-16_dp, &
"m") !! reduced neutron Compton wavelength
type(codata_constant_type), parameter, public :: REDUCED_PLANCK_CONSTANT = &
codata_constant_type("reduced Planck constant", &
1.054571817e-34_dp, 0.0_dp, &
"J s") !! reduced Planck constant
type(codata_constant_type), parameter, public :: REDUCED_PLANCK_CONSTANT_IN_EV_S = &
codata_constant_type("reduced Planck constant in eV s", &
6.582119569e-16_dp, 0.0_dp, &
"eV s") !! reduced Planck constant in eV s
type(codata_constant_type), parameter, public :: REDUCED_PLANCK_CONSTANT_TIMES_C_IN_MEV_FM = &
codata_constant_type("reduced Planck constant times c in MeV fm", &
197.3269804_dp, 0.0_dp, &
"MeV fm") !! reduced Planck constant times c in MeV fm
type(codata_constant_type), parameter, public :: REDUCED_PROTON_COMPTON_WAVELENGTH = &
codata_constant_type("reduced proton Compton wavelength", &
2.10308910051e-16_dp, 0.00000000066e-16_dp, &
"m") !! reduced proton Compton wavelength
type(codata_constant_type), parameter, public :: REDUCED_TAU_COMPTON_WAVELENGTH = &
codata_constant_type("reduced tau Compton wavelength", &
1.110538e-16_dp, 0.000075e-16_dp, &
"m") !! reduced tau Compton wavelength
type(codata_constant_type), parameter, public :: RYDBERG_CONSTANT = &
codata_constant_type("Rydberg constant", &
10973731.568157_dp, 0.000012_dp, &
"m^-1") !! Rydberg constant
type(codata_constant_type), parameter, public :: RYDBERG_CONSTANT_TIMES_C_IN_HZ = &
codata_constant_type("Rydberg constant times c in Hz", &
3.2898419602500e15_dp, 0.0000000000036e15_dp, &
"Hz") !! Rydberg constant times c in Hz
type(codata_constant_type), parameter, public :: RYDBERG_CONSTANT_TIMES_HC_IN_EV = &
codata_constant_type("Rydberg constant times hc in eV", &
13.605693122990_dp, 0.000000000015_dp, &
"eV") !! Rydberg constant times hc in eV
type(codata_constant_type), parameter, public :: RYDBERG_CONSTANT_TIMES_HC_IN_J = &
codata_constant_type("Rydberg constant times hc in J", &
2.1798723611030e-18_dp, 0.0000000000024e-18_dp, &
"J") !! Rydberg constant times hc in J
type(codata_constant_type), parameter, public :: SACKUR_TETRODE_CONSTANT_1_K_100_KPA = &
codata_constant_type("Sackur-Tetrode constant (1 K, 100 kPa)", &
-1.15170753496_dp, 0.00000000047_dp, &
"") !! Sackur-Tetrode constant (1 K, 100 kPa)
type(codata_constant_type), parameter, public :: SACKUR_TETRODE_CONSTANT_1_K_101_325_KPA = &
codata_constant_type("Sackur-Tetrode constant (1 K, 101.325 kPa)", &
-1.16487052149_dp, 0.00000000047_dp, &
"") !! Sackur-Tetrode constant (1 K, 101.325 kPa)
type(codata_constant_type), parameter, public :: SECOND_RADIATION_CONSTANT = &
codata_constant_type("second radiation constant", &
1.438776877e-2_dp, 0.0_dp, &
"m K") !! second radiation constant
type(codata_constant_type), parameter, public :: SHIELDED_HELION_GYROMAG_RATIO = &
codata_constant_type("shielded helion gyromag. ratio", &
2.0378946078e8_dp, 0.0000000018e8_dp, &
"s^-1 T^-1") !! shielded helion gyromag. ratio
type(codata_constant_type), parameter, public :: SHIELDED_HELION_GYROMAG_RATIO_IN_MHZ_T = &
codata_constant_type("shielded helion gyromag. ratio in MHz/T", &
32.434100033_dp, 0.000000028_dp, &
"MHz T^-1") !! shielded helion gyromag. ratio in MHz/T
type(codata_constant_type), parameter, public :: SHIELDED_HELION_MAG_MOM = &
codata_constant_type("shielded helion mag. mom.", &
-1.07455311035e-26_dp, 0.00000000093e-26_dp, &
"J T^-1") !! shielded helion mag. mom.
type(codata_constant_type), parameter, public :: SHIELDED_HELION_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("shielded helion mag. mom. to Bohr magneton ratio", &
-1.15867149457e-3_dp, 0.00000000094e-3_dp, &
"") !! shielded helion mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: SHIELDED_HELION_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("shielded helion mag. mom. to nuclear magneton ratio", &
-2.1274977624_dp, 0.0000000017_dp, &
"") !! shielded helion mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: SHIELDED_HELION_TO_PROTON_MAG_MOM_RATIO = &
codata_constant_type("shielded helion to proton mag. mom. ratio", &
-0.76176657721_dp, 0.00000000066_dp, &
"") !! shielded helion to proton mag. mom. ratio
type(codata_constant_type), parameter, public :: SHIELDED_HELION_TO_SHIELDED_PROTON_MAG_MOM_RATIO = &
codata_constant_type("shielded helion to shielded proton mag. mom. ratio", &
-0.7617861334_dp, 0.0000000031_dp, &
"") !! shielded helion to shielded proton mag. mom. ratio
type(codata_constant_type), parameter, public :: SHIELDED_PROTON_GYROMAG_RATIO = &
codata_constant_type("shielded proton gyromag. ratio", &
2.675153194e8_dp, 0.000000011e8_dp, &
"s^-1 T^-1") !! shielded proton gyromag. ratio
type(codata_constant_type), parameter, public :: SHIELDED_PROTON_GYROMAG_RATIO_IN_MHZ_T = &
codata_constant_type("shielded proton gyromag. ratio in MHz/T", &
42.57638543_dp, 0.00000017_dp, &
"MHz T^-1") !! shielded proton gyromag. ratio in MHz/T
type(codata_constant_type), parameter, public :: SHIELDED_PROTON_MAG_MOM = &
codata_constant_type("shielded proton mag. mom.", &
1.4105705830e-26_dp, 0.0000000058e-26_dp, &
"J T^-1") !! shielded proton mag. mom.
type(codata_constant_type), parameter, public :: SHIELDED_PROTON_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("shielded proton mag. mom. to Bohr magneton ratio", &
1.5209931551e-3_dp, 0.0000000062e-3_dp, &
"") !! shielded proton mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: SHIELDED_PROTON_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("shielded proton mag. mom. to nuclear magneton ratio", &
2.792775648_dp, 0.000000011_dp, &
"") !! shielded proton mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: SHIELDING_DIFFERENCE_OF_D_AND_P_IN_HD = &
codata_constant_type("shielding difference of d and p in HD", &
1.98770e-8_dp, 0.00010e-8_dp, &
"") !! shielding difference of d and p in HD
type(codata_constant_type), parameter, public :: SHIELDING_DIFFERENCE_OF_T_AND_P_IN_HT = &
codata_constant_type("shielding difference of t and p in HT", &
2.39450e-8_dp, 0.00020e-8_dp, &
"") !! shielding difference of t and p in HT
type(codata_constant_type), parameter, public :: SPEED_OF_LIGHT_IN_VACUUM = &
codata_constant_type("speed of light in vacuum", &
299792458_dp, 0.0_dp, &
"m s^-1") !! speed of light in vacuum
type(codata_constant_type), parameter, public :: STANDARD_ACCELERATION_OF_GRAVITY = &
codata_constant_type("standard acceleration of gravity", &
9.80665_dp, 0.0_dp, &
"m s^-2") !! standard acceleration of gravity
type(codata_constant_type), parameter, public :: STANDARD_ATMOSPHERE = &
codata_constant_type("standard atmosphere", &
101325_dp, 0.0_dp, &
"Pa") !! standard atmosphere
type(codata_constant_type), parameter, public :: STANDARD_STATE_PRESSURE = &
codata_constant_type("standard-state pressure", &
100000_dp, 0.0_dp, &
"Pa") !! standard-state pressure
type(codata_constant_type), parameter, public :: STEFAN_BOLTZMANN_CONSTANT = &
codata_constant_type("Stefan-Boltzmann constant", &
5.670374419e-8_dp, 0.0_dp, &
"W m^-2 K^-4") !! Stefan-Boltzmann constant
type(codata_constant_type), parameter, public :: TAU_COMPTON_WAVELENGTH = &
codata_constant_type("tau Compton wavelength", &
6.97771e-16_dp, 0.00047e-16_dp, &
"m") !! tau Compton wavelength
type(codata_constant_type), parameter, public :: TAU_ELECTRON_MASS_RATIO = &
codata_constant_type("tau-electron mass ratio", &
3477.23_dp, 0.23_dp, &
"") !! tau-electron mass ratio
type(codata_constant_type), parameter, public :: TAU_ENERGY_EQUIVALENT = &
codata_constant_type("tau energy equivalent", &
1776.86_dp, 0.12_dp, &
"MeV") !! tau energy equivalent
type(codata_constant_type), parameter, public :: TAU_MASS = &
codata_constant_type("tau mass", &
3.16754e-27_dp, 0.00021e-27_dp, &
"kg") !! tau mass
type(codata_constant_type), parameter, public :: TAU_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("tau mass energy equivalent", &
2.84684e-10_dp, 0.00019e-10_dp, &
"J") !! tau mass energy equivalent
type(codata_constant_type), parameter, public :: TAU_MASS_IN_U = &
codata_constant_type("tau mass in u", &
1.90754_dp, 0.00013_dp, &
"u") !! tau mass in u
type(codata_constant_type), parameter, public :: TAU_MOLAR_MASS = &
codata_constant_type("tau molar mass", &
1.90754e-3_dp, 0.00013e-3_dp, &
"kg mol^-1") !! tau molar mass
type(codata_constant_type), parameter, public :: TAU_MUON_MASS_RATIO = &
codata_constant_type("tau-muon mass ratio", &
16.8170_dp, 0.0011_dp, &
"") !! tau-muon mass ratio
type(codata_constant_type), parameter, public :: TAU_NEUTRON_MASS_RATIO = &
codata_constant_type("tau-neutron mass ratio", &
1.89115_dp, 0.00013_dp, &
"") !! tau-neutron mass ratio
type(codata_constant_type), parameter, public :: TAU_PROTON_MASS_RATIO = &
codata_constant_type("tau-proton mass ratio", &
1.89376_dp, 0.00013_dp, &
"") !! tau-proton mass ratio
type(codata_constant_type), parameter, public :: THOMSON_CROSS_SECTION = &
codata_constant_type("Thomson cross section", &
6.6524587051e-29_dp, 0.0000000062e-29_dp, &
"m^2") !! Thomson cross section
type(codata_constant_type), parameter, public :: TRITON_ELECTRON_MASS_RATIO = &
codata_constant_type("triton-electron mass ratio", &
5496.92153551_dp, 0.00000021_dp, &
"") !! triton-electron mass ratio
type(codata_constant_type), parameter, public :: TRITON_G_FACTOR = &
codata_constant_type("triton g factor", &
5.957924930_dp, 0.000000012_dp, &
"") !! triton g factor
type(codata_constant_type), parameter, public :: TRITON_MAG_MOM = &
codata_constant_type("triton mag. mom.", &
1.5046095178e-26_dp, 0.0000000030e-26_dp, &
"J T^-1") !! triton mag. mom.
type(codata_constant_type), parameter, public :: TRITON_MAG_MOM_TO_BOHR_MAGNETON_RATIO = &
codata_constant_type("triton mag. mom. to Bohr magneton ratio", &
1.6223936648e-3_dp, 0.0000000032e-3_dp, &
"") !! triton mag. mom. to Bohr magneton ratio
type(codata_constant_type), parameter, public :: TRITON_MAG_MOM_TO_NUCLEAR_MAGNETON_RATIO = &
codata_constant_type("triton mag. mom. to nuclear magneton ratio", &
2.9789624650_dp, 0.0000000059_dp, &
"") !! triton mag. mom. to nuclear magneton ratio
type(codata_constant_type), parameter, public :: TRITON_MASS = &
codata_constant_type("triton mass", &
5.0073567512e-27_dp, 0.0000000016e-27_dp, &
"kg") !! triton mass
type(codata_constant_type), parameter, public :: TRITON_MASS_ENERGY_EQUIVALENT = &
codata_constant_type("triton mass energy equivalent", &
4.5003878119e-10_dp, 0.0000000014e-10_dp, &
"J") !! triton mass energy equivalent
type(codata_constant_type), parameter, public :: TRITON_MASS_ENERGY_EQUIVALENT_IN_MEV = &
codata_constant_type("triton mass energy equivalent in MeV", &
2808.92113668_dp, 0.00000088_dp, &
"MeV") !! triton mass energy equivalent in MeV
type(codata_constant_type), parameter, public :: TRITON_MASS_IN_U = &
codata_constant_type("triton mass in u", &
3.01550071597_dp, 0.00000000010_dp, &
"u") !! triton mass in u
type(codata_constant_type), parameter, public :: TRITON_MOLAR_MASS = &
codata_constant_type("triton molar mass", &
3.01550071913e-3_dp, 0.00000000094e-3_dp, &
"kg mol^-1") !! triton molar mass
type(codata_constant_type), parameter, public :: TRITON_PROTON_MASS_RATIO = &
codata_constant_type("triton-proton mass ratio", &
2.99371703403_dp, 0.00000000010_dp, &
"") !! triton-proton mass ratio
type(codata_constant_type), parameter, public :: TRITON_RELATIVE_ATOMIC_MASS = &
codata_constant_type("triton relative atomic mass", &
3.01550071597_dp, 0.00000000010_dp, &
"") !! triton relative atomic mass
type(codata_constant_type), parameter, public :: TRITON_TO_PROTON_MAG_MOM_RATIO = &
codata_constant_type("triton to proton mag. mom. ratio", &
1.0666399189_dp, 0.0000000021_dp, &
"") !! triton to proton mag. mom. ratio
type(codata_constant_type), parameter, public :: UNIFIED_ATOMIC_MASS_UNIT = &
codata_constant_type("unified atomic mass unit", &
1.66053906892e-27_dp, 0.00000000052e-27_dp, &
"kg") !! unified atomic mass unit
type(codata_constant_type), parameter, public :: VACUUM_ELECTRIC_PERMITTIVITY = &
codata_constant_type("vacuum electric permittivity", &
8.8541878188e-12_dp, 0.0000000014e-12_dp, &
"F m^-1") !! vacuum electric permittivity
type(codata_constant_type), parameter, public :: VACUUM_MAG_PERMEABILITY = &
codata_constant_type("vacuum mag. permeability", &
1.25663706127e-6_dp, 0.00000000020e-6_dp, &
"N A^-2") !! vacuum mag. permeability
type(codata_constant_type), parameter, public :: VON_KLITZING_CONSTANT = &
codata_constant_type("von Klitzing constant", &
25812.80745_dp, 0.0_dp, &
"ohm") !! von Klitzing constant
type(codata_constant_type), parameter, public :: WEAK_MIXING_ANGLE = &
codata_constant_type("weak mixing angle", &
0.22305_dp, 0.00023_dp, &
"") !! weak mixing angle
type(codata_constant_type), parameter, public :: WIEN_FREQUENCY_DISPLACEMENT_LAW_CONSTANT = &
codata_constant_type("Wien frequency displacement law constant", &
5.878925757e10_dp, 0.0_dp, &
"Hz K^-1") !! Wien frequency displacement law constant
type(codata_constant_type), parameter, public :: WIEN_WAVELENGTH_DISPLACEMENT_LAW_CONSTANT = &
codata_constant_type("Wien wavelength displacement law constant", &
2.897771955e-3_dp, 0.0_dp, &
"m K") !! Wien wavelength displacement law constant
type(codata_constant_type), parameter, public :: W_TO_Z_MASS_RATIO = &
codata_constant_type("W to Z mass ratio", &
0.88145_dp, 0.00013_dp, &
"") !! W to Z mass ratio
end module stdlib_codata fortran-lang-stdlib-0ede301/src/constants/CMakeLists.txt 0000664 0001750 0001750 00000000462 15135654166 023533 0 ustar alastair alastair set(constants_fppFiles
stdlib_codata_type.fypp
stdlib_constants.fypp
)
set(constants_f90Files
stdlib_codata.f90
)
configure_stdlib_target(${PROJECT_NAME}_constants constants_f90Files constants_fppFiles "")
target_link_libraries(${PROJECT_NAME}_constants PUBLIC ${PROJECT_NAME}_core)
fortran-lang-stdlib-0ede301/src/blas/ 0000775 0001750 0001750 00000000000 15135654166 017676 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/blas/stdlib_blas_level2_gen.fypp 0000664 0001750 0001750 00000326072 15135654166 025174 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_blas) stdlib_blas_level2_gen
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_sgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! SGEMV performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
character, intent(in) :: trans
! Array Arguments
real(sp), intent(in) :: a(lda,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (lda0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,leny
y(i) = zero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,leny
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
do i = 1,m
y(i) = y(i) + temp*a(i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
do i = 1,m
y(iy) = y(iy) + temp*a(i,j)
iy = iy + incy
end do
jx = jx + incx
end do
end if
else
! form y := alpha*a**t*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = zero
do i = 1,m
temp = temp + a(i,j)*x(i)
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = zero
ix = kx
do i = 1,m
temp = temp + a(i,j)*x(ix)
ix = ix + incx
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_sgemv
pure module subroutine stdlib${ii}$_dgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! DGEMV performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
character, intent(in) :: trans
! Array Arguments
real(dp), intent(in) :: a(lda,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(dp) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (lda0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,leny
y(i) = zero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,leny
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
do i = 1,m
y(i) = y(i) + temp*a(i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
do i = 1,m
y(iy) = y(iy) + temp*a(i,j)
iy = iy + incy
end do
jx = jx + incx
end do
end if
else
! form y := alpha*a**t*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = zero
do i = 1,m
temp = temp + a(i,j)*x(i)
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = zero
ix = kx
do i = 1,m
temp = temp + a(i,j)*x(ix)
ix = ix + incx
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_dgemv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_${rk}$
!! DGEMV: performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
character, intent(in) :: trans
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), x(*)
real(${rk}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (lda0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,leny
y(i) = zero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,leny
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
do i = 1,m
y(i) = y(i) + temp*a(i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
do i = 1,m
y(iy) = y(iy) + temp*a(i,j)
iy = iy + incy
end do
jx = jx + incx
end do
end if
else
! form y := alpha*a**t*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = zero
do i = 1,m
temp = temp + a(i,j)*x(i)
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = zero
ix = kx
do i = 1,m
temp = temp + a(i,j)*x(ix)
ix = ix + incx
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$gemv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! CGEMV performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
!! y := alpha*A**H*x + beta*y,
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
character, intent(in) :: trans
! Array Arguments
complex(sp), intent(in) :: a(lda,*), x(*)
complex(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny
logical(lk) :: noconj
! Intrinsic Functions
intrinsic :: conjg,max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (lda0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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 cone pass through a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,leny
y(i) = czero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,leny
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
do i = 1,m
y(i) = y(i) + temp*a(i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
do i = 1,m
y(iy) = y(iy) + temp*a(i,j)
iy = iy + incy
end do
jx = jx + incx
end do
end if
else
! form y := alpha*a**t*x + y or y := alpha*a**h*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = czero
if (noconj) then
do i = 1,m
temp = temp + a(i,j)*x(i)
end do
else
do i = 1,m
temp = temp + conjg(a(i,j))*x(i)
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = czero
ix = kx
if (noconj) then
do i = 1,m
temp = temp + a(i,j)*x(ix)
ix = ix + incx
end do
else
do i = 1,m
temp = temp + conjg(a(i,j))*x(ix)
ix = ix + incx
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_cgemv
pure module subroutine stdlib${ii}$_zgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! ZGEMV performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
!! y := alpha*A**H*x + beta*y,
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
character, intent(in) :: trans
! Array Arguments
complex(dp), intent(in) :: a(lda,*), x(*)
complex(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny
logical(lk) :: noconj
! Intrinsic Functions
intrinsic :: conjg,max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (lda0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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 cone pass through a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,leny
y(i) = czero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,leny
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
do i = 1,m
y(i) = y(i) + temp*a(i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
do i = 1,m
y(iy) = y(iy) + temp*a(i,j)
iy = iy + incy
end do
jx = jx + incx
end do
end if
else
! form y := alpha*a**t*x + y or y := alpha*a**h*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = czero
if (noconj) then
do i = 1,m
temp = temp + a(i,j)*x(i)
end do
else
do i = 1,m
temp = temp + conjg(a(i,j))*x(i)
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = czero
ix = kx
if (noconj) then
do i = 1,m
temp = temp + a(i,j)*x(ix)
ix = ix + incx
end do
else
do i = 1,m
temp = temp + conjg(a(i,j))*x(ix)
ix = ix + incx
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_zgemv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_${ck}$
!! ZGEMV: performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
!! y := alpha*A**H*x + beta*y,
!! where alpha and beta are scalars, x and y are vectors and A is an
!! m by n matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
character, intent(in) :: trans
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), x(*)
complex(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny
logical(lk) :: noconj
! Intrinsic Functions
intrinsic :: conjg,max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (lda0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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 cone pass through a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,leny
y(i) = czero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,leny
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
do i = 1,m
y(i) = y(i) + temp*a(i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
do i = 1,m
y(iy) = y(iy) + temp*a(i,j)
iy = iy + incy
end do
jx = jx + incx
end do
end if
else
! form y := alpha*a**t*x + y or y := alpha*a**h*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = czero
if (noconj) then
do i = 1,m
temp = temp + a(i,j)*x(i)
end do
else
do i = 1,m
temp = temp + conjg(a(i,j))*x(i)
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = czero
ix = kx
if (noconj) then
do i = 1,m
temp = temp + a(i,j)*x(ix)
ix = ix + incx
end do
else
do i = 1,m
temp = temp + conjg(a(i,j))*x(ix)
ix = ix + incx
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$gemv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sger(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_sp
!! SGER performs the rank 1 operation
!! A := alpha*x*y**T + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=zero) then
temp = alpha*y(jy)
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=zero) then
temp = alpha*y(jy)
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_sger
pure module subroutine stdlib${ii}$_dger(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_dp
!! DGER performs the rank 1 operation
!! A := alpha*x*y**T + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
real(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=zero) then
temp = alpha*y(jy)
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=zero) then
temp = alpha*y(jy)
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_dger
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ger(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_${rk}$
!! DGER: performs the rank 1 operation
!! A := alpha*x*y**T + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=zero) then
temp = alpha*y(jy)
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=zero) then
temp = alpha*y(jy)
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_${ri}$ger
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgerc(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_sp
!! CGERC performs the rank 1 operation
!! A := alpha*x*y**H + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: conjg,max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*conjg(y(jy))
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*conjg(y(jy))
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_cgerc
pure module subroutine stdlib${ii}$_zgerc(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_dp
!! ZGERC performs the rank 1 operation
!! A := alpha*x*y**H + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: conjg,max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*conjg(y(jy))
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*conjg(y(jy))
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_zgerc
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gerc(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_${ck}$
!! ZGERC: performs the rank 1 operation
!! A := alpha*x*y**H + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: conjg,max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*conjg(y(jy))
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*conjg(y(jy))
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_${ci}$gerc
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgeru(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_sp
!! CGERU performs the rank 1 operation
!! A := alpha*x*y**T + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*y(jy)
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*y(jy)
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_cgeru
pure module subroutine stdlib${ii}$_zgeru(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_dp
!! ZGERU performs the rank 1 operation
!! A := alpha*x*y**T + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*y(jy)
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*y(jy)
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_zgeru
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$geru(m,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_${ck}$
!! ZGERU: performs the rank 1 operation
!! A := alpha*x*y**T + 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, j, jy, kx
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (m<0) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
jy = 1
else
jy = 1 - (n-1)*incy
end if
if (incx==1) then
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*y(jy)
do i = 1,m
a(i,j) = a(i,j) + x(i)*temp
end do
end if
jy = jy + incy
end do
else
if (incx>0) then
kx = 1
else
kx = 1 - (m-1)*incx
end if
do j = 1,n
if (y(jy)/=czero) then
temp = alpha*y(jy)
ix = kx
do i = 1,m
a(i,j) = a(i,j) + x(ix)*temp
ix = ix + incx
end do
end if
jy = jy + incy
end do
end if
return
end subroutine stdlib${ii}$_${ci}$geru
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cher(uplo,n,alpha,x,incx,a,lda)
use stdlib_blas_constants_sp
!! CHER performs the hermitian rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n hermitian matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kx
! Intrinsic Functions
intrinsic :: conjg,max,real
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through the triangular part
! of a.
if (stdlib_lsame(uplo,'U')) then
! form a when a is stored in the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
do i = 1,j - 1
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
a(j,j) = real(a(j,j),KIND=sp) +real(x(j)*temp1+y(j)*temp2,KIND=sp)
else
a(j,j) = real(a(j,j),KIND=sp)
end if
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ix = kx
iy = ky
do i = 1,j - 1
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
a(j,j) = real(a(j,j),KIND=sp) +real(x(jx)*temp1+y(jy)*temp2,KIND=sp)
else
a(j,j) = real(a(j,j),KIND=sp)
end if
jx = jx + incx
jy = jy + incy
end do
end if
else
! form a when a is stored in the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
a(j,j) = real(a(j,j),KIND=sp) +real(x(j)*temp1+y(j)*temp2,KIND=sp)
do i = j + 1,n
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
else
a(j,j) = real(a(j,j),KIND=sp)
end if
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
a(j,j) = real(a(j,j),KIND=sp) +real(x(jx)*temp1+y(jy)*temp2,KIND=sp)
ix = jx
iy = jy
do i = j + 1,n
ix = ix + incx
iy = iy + incy
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
end do
else
a(j,j) = real(a(j,j),KIND=sp)
end if
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_cher2
pure module subroutine stdlib${ii}$_zher2(uplo,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_dp
!! ZHER2 performs the hermitian rank 2 operation
!! A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
!! where alpha is a scalar, x and y are n element vectors and A is an n
!! by n hermitian matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: real,conjg,max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through the triangular part
! of a.
if (stdlib_lsame(uplo,'U')) then
! form a when a is stored in the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
do i = 1,j - 1
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
a(j,j) = real(a(j,j),KIND=dp) +real(x(j)*temp1+y(j)*temp2,KIND=dp)
else
a(j,j) = real(a(j,j),KIND=dp)
end if
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ix = kx
iy = ky
do i = 1,j - 1
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
a(j,j) = real(a(j,j),KIND=dp) +real(x(jx)*temp1+y(jy)*temp2,KIND=dp)
else
a(j,j) = real(a(j,j),KIND=dp)
end if
jx = jx + incx
jy = jy + incy
end do
end if
else
! form a when a is stored in the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
a(j,j) = real(a(j,j),KIND=dp) +real(x(j)*temp1+y(j)*temp2,KIND=dp)
do i = j + 1,n
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
else
a(j,j) = real(a(j,j),KIND=dp)
end if
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
a(j,j) = real(a(j,j),KIND=dp) +real(x(jx)*temp1+y(jy)*temp2,KIND=dp)
ix = jx
iy = jy
do i = j + 1,n
ix = ix + incx
iy = iy + incy
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
end do
else
a(j,j) = real(a(j,j),KIND=dp)
end if
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_zher2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$her2(uplo,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_${ck}$
!! ZHER2: performs the hermitian rank 2 operation
!! A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
!! where alpha is a scalar, x and y are n element vectors and A is an n
!! by n hermitian matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: real,conjg,max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through the triangular part
! of a.
if (stdlib_lsame(uplo,'U')) then
! form a when a is stored in the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
do i = 1,j - 1
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
a(j,j) = real(a(j,j),KIND=${ck}$) +real(x(j)*temp1+y(j)*temp2,KIND=${ck}$)
else
a(j,j) = real(a(j,j),KIND=${ck}$)
end if
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ix = kx
iy = ky
do i = 1,j - 1
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
a(j,j) = real(a(j,j),KIND=${ck}$) +real(x(jx)*temp1+y(jy)*temp2,KIND=${ck}$)
else
a(j,j) = real(a(j,j),KIND=${ck}$)
end if
jx = jx + incx
jy = jy + incy
end do
end if
else
! form a when a is stored in the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
a(j,j) = real(a(j,j),KIND=${ck}$) +real(x(j)*temp1+y(j)*temp2,KIND=${ck}$)
do i = j + 1,n
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
else
a(j,j) = real(a(j,j),KIND=${ck}$)
end if
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
a(j,j) = real(a(j,j),KIND=${ck}$) +real(x(jx)*temp1+y(jy)*temp2,KIND=${ck}$)
ix = jx
iy = jy
do i = j + 1,n
ix = ix + incx
iy = iy + incy
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
end do
else
a(j,j) = real(a(j,j),KIND=${ck}$)
end if
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$her2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! CHEMV 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 hermitian matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(in) :: a(lda,*), x(*)
complex(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: conjg,max,real
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through the triangular part
! of a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(uplo,'U')) then
! form y when a is stored in upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
do i = 1,j - 1
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(i)
end do
y(j) = y(j) + temp1*real(a(j,j),KIND=sp) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
do i = 1,j - 1
y(iy) = y(iy) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(a(j,j),KIND=sp) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(a(j,j),KIND=sp)
do i = j + 1,n
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(a(j,j),KIND=sp)
ix = jx
iy = jy
do i = j + 1,n
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_chemv
pure module subroutine stdlib${ii}$_zhemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! ZHEMV 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 hermitian matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(in) :: a(lda,*), x(*)
complex(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: real,conjg,max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through the triangular part
! of a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(uplo,'U')) then
! form y when a is stored in upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
do i = 1,j - 1
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(i)
end do
y(j) = y(j) + temp1*real(a(j,j),KIND=dp) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
do i = 1,j - 1
y(iy) = y(iy) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(a(j,j),KIND=dp) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(a(j,j),KIND=dp)
do i = j + 1,n
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(a(j,j),KIND=dp)
ix = jx
iy = jy
do i = j + 1,n
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_zhemv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_${ck}$
!! ZHEMV: 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 hermitian matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), x(*)
complex(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: real,conjg,max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through the triangular part
! of a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(uplo,'U')) then
! form y when a is stored in upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
do i = 1,j - 1
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(i)
end do
y(j) = y(j) + temp1*real(a(j,j),KIND=${ck}$) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
do i = 1,j - 1
y(iy) = y(iy) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(a(j,j),KIND=${ck}$) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(a(j,j),KIND=${ck}$)
do i = j + 1,n
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(a(j,j),KIND=${ck}$)
ix = jx
iy = jy
do i = j + 1,n
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*a(i,j)
temp2 = temp2 + conjg(a(i,j))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$hemv
#:endif
#:endfor
#:endfor
end submodule stdlib_blas_level2_gen
fortran-lang-stdlib-0ede301/src/blas/stdlib_blas_level2_ban.fypp 0000664 0001750 0001750 00000156136 15135654166 025165 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_blas) stdlib_blas_level2_ban
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_sgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! SGBMV performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n
character, intent(in) :: trans
! Array Arguments
real(sp), intent(in) :: a(lda,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (kl<0) then
info = 4
else if (ku<0) then
info = 5
else if (lda< (kl+ku+1)) then
info = 8
else if (incx==0) then
info = 10
else if (incy==0) then
info = 13
end if
if (info/=0) then
call stdlib${ii}$_xerbla('SGBMV ',info)
return
end if
! quick return if possible.
if ((m==0) .or. (n==0) .or.((alpha==zero).and. (beta==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 (stdlib_lsame(trans,'N')) then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if (incx>0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,leny
y(i) = zero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,leny
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
kup1 = ku + 1
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(i) = y(i) + temp*a(k+i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(iy) = y(iy) + temp*a(k+i,j)
iy = iy + incy
end do
jx = jx + incx
if (j>ku) ky = ky + incy
end do
end if
else
! form y := alpha*a**t*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = zero
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(i)
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = zero
ix = kx
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(ix)
ix = ix + incx
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
if (j>ku) kx = kx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_sgbmv
pure module subroutine stdlib${ii}$_dgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! DGBMV performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n
character, intent(in) :: trans
! Array Arguments
real(dp), intent(in) :: a(lda,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(dp) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (kl<0) then
info = 4
else if (ku<0) then
info = 5
else if (lda< (kl+ku+1)) then
info = 8
else if (incx==0) then
info = 10
else if (incy==0) then
info = 13
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DGBMV ',info)
return
end if
! quick return if possible.
if ((m==0) .or. (n==0) .or.((alpha==zero).and. (beta==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 (stdlib_lsame(trans,'N')) then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if (incx>0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,leny
y(i) = zero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,leny
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
kup1 = ku + 1
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(i) = y(i) + temp*a(k+i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(iy) = y(iy) + temp*a(k+i,j)
iy = iy + incy
end do
jx = jx + incx
if (j>ku) ky = ky + incy
end do
end if
else
! form y := alpha*a**t*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = zero
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(i)
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = zero
ix = kx
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(ix)
ix = ix + incx
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
if (j>ku) kx = kx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_dgbmv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$gbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_${rk}$
!! DGBMV: performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n
character, intent(in) :: trans
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), x(*)
real(${rk}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (kl<0) then
info = 4
else if (ku<0) then
info = 5
else if (lda< (kl+ku+1)) then
info = 8
else if (incx==0) then
info = 10
else if (incy==0) then
info = 13
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DGBMV ',info)
return
end if
! quick return if possible.
if ((m==0) .or. (n==0) .or.((alpha==zero).and. (beta==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 (stdlib_lsame(trans,'N')) then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if (incx>0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,leny
y(i) = zero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,leny
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
kup1 = ku + 1
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(i) = y(i) + temp*a(k+i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(iy) = y(iy) + temp*a(k+i,j)
iy = iy + incy
end do
jx = jx + incx
if (j>ku) ky = ky + incy
end do
end if
else
! form y := alpha*a**t*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = zero
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(i)
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = zero
ix = kx
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(ix)
ix = ix + incx
end do
y(jy) = y(jy) + alpha*temp
jy = jy + incy
if (j>ku) kx = kx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$gbmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! CGBMV performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
!! y := alpha*A**H*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n
character, intent(in) :: trans
! Array Arguments
complex(sp), intent(in) :: a(lda,*), x(*)
complex(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny
logical(lk) :: noconj
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (kl<0) then
info = 4
else if (ku<0) then
info = 5
else if (lda< (kl+ku+1)) then
info = 8
else if (incx==0) then
info = 10
else if (incy==0) then
info = 13
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CGBMV ',info)
return
end if
! quick return if possible.
if ((m==0) .or. (n==0) .or.((alpha==czero).and. (beta==cone))) return
noconj = stdlib_lsame(trans,'T')
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if (stdlib_lsame(trans,'N')) then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if (incx>0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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 cone pass through the band part of a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,leny
y(i) = czero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,leny
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
kup1 = ku + 1
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(i) = y(i) + temp*a(k+i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(iy) = y(iy) + temp*a(k+i,j)
iy = iy + incy
end do
jx = jx + incx
if (j>ku) ky = ky + incy
end do
end if
else
! form y := alpha*a**t*x + y or y := alpha*a**h*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = czero
k = kup1 - j
if (noconj) then
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(i)
end do
else
do i = max(1,j-ku),min(m,j+kl)
temp = temp + conjg(a(k+i,j))*x(i)
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = czero
ix = kx
k = kup1 - j
if (noconj) then
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(ix)
ix = ix + incx
end do
else
do i = max(1,j-ku),min(m,j+kl)
temp = temp + conjg(a(k+i,j))*x(ix)
ix = ix + incx
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
if (j>ku) kx = kx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_cgbmv
pure module subroutine stdlib${ii}$_zgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! ZGBMV performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
!! y := alpha*A**H*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n
character, intent(in) :: trans
! Array Arguments
complex(dp), intent(in) :: a(lda,*), x(*)
complex(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny
logical(lk) :: noconj
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (kl<0) then
info = 4
else if (ku<0) then
info = 5
else if (lda< (kl+ku+1)) then
info = 8
else if (incx==0) then
info = 10
else if (incy==0) then
info = 13
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZGBMV ',info)
return
end if
! quick return if possible.
if ((m==0) .or. (n==0) .or.((alpha==czero).and. (beta==cone))) return
noconj = stdlib_lsame(trans,'T')
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if (stdlib_lsame(trans,'N')) then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if (incx>0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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 cone pass through the band part of a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,leny
y(i) = czero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,leny
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
kup1 = ku + 1
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(i) = y(i) + temp*a(k+i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(iy) = y(iy) + temp*a(k+i,j)
iy = iy + incy
end do
jx = jx + incx
if (j>ku) ky = ky + incy
end do
end if
else
! form y := alpha*a**t*x + y or y := alpha*a**h*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = czero
k = kup1 - j
if (noconj) then
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(i)
end do
else
do i = max(1,j-ku),min(m,j+kl)
temp = temp + conjg(a(k+i,j))*x(i)
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = czero
ix = kx
k = kup1 - j
if (noconj) then
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(ix)
ix = ix + incx
end do
else
do i = max(1,j-ku),min(m,j+kl)
temp = temp + conjg(a(k+i,j))*x(ix)
ix = ix + incx
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
if (j>ku) kx = kx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_zgbmv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$gbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_${ck}$
!! ZGBMV: performs one of the matrix-vector operations
!! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
!! y := alpha*A**H*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n
character, intent(in) :: trans
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), x(*)
complex(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny
logical(lk) :: noconj
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 1
else if (m<0) then
info = 2
else if (n<0) then
info = 3
else if (kl<0) then
info = 4
else if (ku<0) then
info = 5
else if (lda< (kl+ku+1)) then
info = 8
else if (incx==0) then
info = 10
else if (incy==0) then
info = 13
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZGBMV ',info)
return
end if
! quick return if possible.
if ((m==0) .or. (n==0) .or.((alpha==czero).and. (beta==cone))) return
noconj = stdlib_lsame(trans,'T')
! set lenx and leny, the lengths of the vectors x and y, and set
! up the start points in x and y.
if (stdlib_lsame(trans,'N')) then
lenx = n
leny = m
else
lenx = m
leny = n
end if
if (incx>0) then
kx = 1
else
kx = 1 - (lenx-1)*incx
end if
if (incy>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 cone pass through the band part of a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,leny
y(i) = czero
end do
else
do i = 1,leny
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,leny
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,leny
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
kup1 = ku + 1
if (stdlib_lsame(trans,'N')) then
! form y := alpha*a*x + y.
jx = kx
if (incy==1) then
do j = 1,n
temp = alpha*x(jx)
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(i) = y(i) + temp*a(k+i,j)
end do
jx = jx + incx
end do
else
do j = 1,n
temp = alpha*x(jx)
iy = ky
k = kup1 - j
do i = max(1,j-ku),min(m,j+kl)
y(iy) = y(iy) + temp*a(k+i,j)
iy = iy + incy
end do
jx = jx + incx
if (j>ku) ky = ky + incy
end do
end if
else
! form y := alpha*a**t*x + y or y := alpha*a**h*x + y.
jy = ky
if (incx==1) then
do j = 1,n
temp = czero
k = kup1 - j
if (noconj) then
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(i)
end do
else
do i = max(1,j-ku),min(m,j+kl)
temp = temp + conjg(a(k+i,j))*x(i)
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
end do
else
do j = 1,n
temp = czero
ix = kx
k = kup1 - j
if (noconj) then
do i = max(1,j-ku),min(m,j+kl)
temp = temp + a(k+i,j)*x(ix)
ix = ix + incx
end do
else
do i = max(1,j-ku),min(m,j+kl)
temp = temp + conjg(a(k+i,j))*x(ix)
ix = ix + incx
end do
end if
y(jy) = y(jy) + alpha*temp
jy = jy + incy
if (j>ku) kx = kx + incx
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$gbmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! CHBMV 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 hermitian band matrix, with k super-diagonals.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, k, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(in) :: a(lda,*), x(*)
complex(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l
! Intrinsic Functions
intrinsic :: conjg,max,min,real
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (k<0) then
info = 3
else if (lda< (k+1)) then
info = 6
else if (incx==0) then
info = 8
else if (incy==0) then
info = 11
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CHBMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==czero).and. (beta==cone))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(uplo,'U')) then
! form y when upper triangle of a is stored.
kplus1 = k + 1
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
l = kplus1 - j
do i = max(1,j-k),j - 1
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(i)
end do
y(j) = y(j) + temp1*real(a(kplus1,j),KIND=sp) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
l = kplus1 - j
do i = max(1,j-k),j - 1
y(iy) = y(iy) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(a(kplus1,j),KIND=sp) + alpha*temp2
jx = jx + incx
jy = jy + incy
if (j>k) then
kx = kx + incx
ky = ky + incy
end if
end do
end if
else
! form y when lower triangle of a is stored.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(a(1,j),KIND=sp)
l = 1 - j
do i = j + 1,min(n,j+k)
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(a(1,j),KIND=sp)
l = 1 - j
ix = jx
iy = jy
do i = j + 1,min(n,j+k)
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_chbmv
pure module subroutine stdlib${ii}$_zhbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! ZHBMV 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 hermitian band matrix, with k super-diagonals.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, k, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(in) :: a(lda,*), x(*)
complex(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l
! Intrinsic Functions
intrinsic :: real,conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (k<0) then
info = 3
else if (lda< (k+1)) then
info = 6
else if (incx==0) then
info = 8
else if (incy==0) then
info = 11
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZHBMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==czero).and. (beta==cone))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(uplo,'U')) then
! form y when upper triangle of a is stored.
kplus1 = k + 1
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
l = kplus1 - j
do i = max(1,j-k),j - 1
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(i)
end do
y(j) = y(j) + temp1*real(a(kplus1,j),KIND=dp) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
l = kplus1 - j
do i = max(1,j-k),j - 1
y(iy) = y(iy) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(a(kplus1,j),KIND=dp) + alpha*temp2
jx = jx + incx
jy = jy + incy
if (j>k) then
kx = kx + incx
ky = ky + incy
end if
end do
end if
else
! form y when lower triangle of a is stored.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(a(1,j),KIND=dp)
l = 1 - j
do i = j + 1,min(n,j+k)
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(a(1,j),KIND=dp)
l = 1 - j
ix = jx
iy = jy
do i = j + 1,min(n,j+k)
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_zhbmv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_${ck}$
!! ZHBMV: 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 hermitian band matrix, with k super-diagonals.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, k, lda, n
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*), x(*)
complex(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l
! Intrinsic Functions
intrinsic :: real,conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (k<0) then
info = 3
else if (lda< (k+1)) then
info = 6
else if (incx==0) then
info = 8
else if (incy==0) then
info = 11
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZHBMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==czero).and. (beta==cone))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 cone pass through a.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
if (stdlib_lsame(uplo,'U')) then
! form y when upper triangle of a is stored.
kplus1 = k + 1
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
l = kplus1 - j
do i = max(1,j-k),j - 1
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(i)
end do
y(j) = y(j) + temp1*real(a(kplus1,j),KIND=${ck}$) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
l = kplus1 - j
do i = max(1,j-k),j - 1
y(iy) = y(iy) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(a(kplus1,j),KIND=${ck}$) + alpha*temp2
jx = jx + incx
jy = jy + incy
if (j>k) then
kx = kx + incx
ky = ky + incy
end if
end do
end if
else
! form y when lower triangle of a is stored.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(a(1,j),KIND=${ck}$)
l = 1 - j
do i = j + 1,min(n,j+k)
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(a(1,j),KIND=${ck}$)
l = 1 - j
ix = jx
iy = jy
do i = j + 1,min(n,j+k)
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*a(l+i,j)
temp2 = temp2 + conjg(a(l+i,j))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$hbmv
#:endif
#:endfor
#:endfor
end submodule stdlib_blas_level2_ban
fortran-lang-stdlib-0ede301/src/blas/stdlib_linalg_blas_aux.fypp 0000664 0001750 0001750 00000024105 15135654166 025265 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
module stdlib_linalg_blas_aux
use stdlib_linalg_constants
implicit none
private
public :: sp,dp,qp,lk,ilp
public :: stdlib_cabs1
public :: stdlib_lsame
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#:for rk,rt,ri in RC_KINDS_TYPES
public :: stdlib${ii}$_i${ri}$amax
#:endfor
public :: stdlib${ii}$_xerbla
public :: stdlib${ii}$_xerbla_array
#:endfor
interface stdlib_cabs1
#:for rk,rt,ri in REAL_KINDS_TYPES
module procedure stdlib_${ri}$cabs1
#:endfor
end interface stdlib_cabs1
contains
#:for ck,ct,ci in REAL_KINDS_TYPES
pure elemental real(${ck}$) function stdlib_${ci}$cabs1(z)
!! DCABS1 computes |Re(.)| + |Im(.)| of a double complex number
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: z
! =====================================================================
! Intrinsic Functions
intrinsic :: abs,real,aimag
stdlib_${ci}$cabs1 = abs(real(z,KIND=${ck}$)) + abs(aimag(z))
return
end function stdlib_${ci}$cabs1
#:endfor
pure elemental logical(lk) function stdlib_lsame(ca,cb)
!! LSAME returns .TRUE. if CA is the same letter as CB regardless of
!! case.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
character, intent(in) :: ca, cb
! =====================================================================
! Intrinsic Functions
intrinsic :: ichar
! Local Scalars
integer(ilp) :: inta, intb, zcode
! test if the characters are equal
stdlib_lsame = ca == cb
if (stdlib_lsame) return
! now test for equivalence if both characters are alphabetic.
zcode = ichar('Z',kind=ilp)
! 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,kind=ilp)
intb = ichar(cb,kind=ilp)
if (zcode==90 .or. zcode==122) then
! ascii is assumed - zcode is the ascii code of either lower or
! upper case 'z'.
if (inta>=97 .and. inta<=122) inta = inta - 32
if (intb>=97 .and. intb<=122) intb = intb - 32
else if (zcode==233 .or. zcode==169) then
! ebcdic is assumed - zcode is the ebcdic code of either lower or
! upper case 'z'.
if (inta>=129 .and. inta<=137 .or.inta>=145 .and. inta<=153 .or.inta>=162 .and. &
inta<=169) inta = inta + 64
if (intb>=129 .and. intb<=137 .or.intb>=145 .and. intb<=153 .or.intb>=162 .and. &
intb<=169) intb = intb + 64
else if (zcode==218 .or. zcode==250) then
! ascii is assumed, on prime machines - zcode is the ascii code
! plus 128 of either lower or upper case 'z'.
if (inta>=225 .and. inta<=250) inta = inta - 32
if (intb>=225 .and. intb<=250) intb = intb - 32
end if
stdlib_lsame = inta == intb
! return
end function stdlib_lsame
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure subroutine stdlib${ii}$_xerbla( srname, info )
!! 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.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
character(len=*), intent(in) :: srname
integer(${ik}$), intent(in) :: info
! =====================================================================
! Intrinsic Functions
intrinsic :: len_trim
! Executable Statements
9999 format( ' ** ON ENTRY TO ', a, ' PARAMETER NUMBER ', i2, ' HAD ','AN ILLEGAL VALUE' )
end subroutine stdlib${ii}$_xerbla
pure subroutine stdlib${ii}$_xerbla_array(srname_array, srname_len, info)
!! XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK
!! and BLAS error handler. Rather than taking a Fortran string argument
!! as the function's name, XERBLA_ARRAY takes an array of single
!! characters along with the array's length. XERBLA_ARRAY then copies
!! up to 32 characters of that array into a Fortran string and passes
!! that to XERBLA. If called with a non-positive SRNAME_LEN,
!! XERBLA_ARRAY will call XERBLA with a string of all blank characters.
!! Say some macro or other device makes XERBLA_ARRAY available to C99
!! by a name lapack_xerbla and with a common Fortran calling convention.
!! Then a C99 program could invoke XERBLA via:
!! {
!! int flen = strlen(__func__);
!! lapack_xerbla(__func__,
!! }
!! Providing XERBLA_ARRAY is not necessary for intercepting LAPACK
!! errors. XERBLA_ARRAY calls XERBLA.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: srname_len, info
! Array Arguments
character(1), intent(in) :: srname_array(srname_len)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i
! Local Arrays
character*32 srname
! Intrinsic Functions
intrinsic :: min,len
! Executable Statements
srname = ''
do i = 1, min( srname_len, len( srname ) )
srname( i:i ) = srname_array( i )
end do
call stdlib${ii}$_xerbla( srname, info )
return
end subroutine stdlib${ii}$_xerbla_array
#:for rk,rt,ri in REAL_KINDS_TYPES
pure integer(${ik}$) function stdlib${ii}$_i${ri}$amax(n,dx,incx) result(iamax)
!! IDAMAX: finds the index of the first element having maximum absolute value.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
! Array Arguments
real(${rk}$), intent(in) :: dx(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: dmax
integer(${ik}$) :: i, ix
! Intrinsic Functions
intrinsic :: abs
iamax = 0
if (n<1 .or. incx<=0) return
iamax = 1
if (n==1) return
if (incx==1) then
! code for increment equal to 1
dmax = abs(dx(1))
do i = 2,n
if (abs(dx(i))>dmax) then
iamax = i
dmax = abs(dx(i))
end if
end do
else
! code for increment not equal to 1
ix = 1
dmax = abs(dx(1))
ix = ix + incx
do i = 2,n
if (abs(dx(ix))>dmax) then
iamax = i
dmax = abs(dx(ix))
end if
ix = ix + incx
end do
end if
return
end function stdlib${ii}$_i${ri}$amax
#:endfor
#:for ck,ct,ci in CMPLX_KINDS_TYPES
pure integer(${ik}$) function stdlib${ii}$_i${ci}$amax(n,zx,incx) result(iamax)
!! IZAMAX: finds the index of the first element having maximum |Re(.)| + |Im(.)|
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
! Array Arguments
complex(${ck}$), intent(in) :: zx(*)
! =====================================================================
! Local Scalars
real(${ck}$) :: dmax
integer(${ik}$) :: i, ix
iamax = 0
if (n<1 .or. incx<=0) return
iamax = 1
if (n==1) return
if (incx==1) then
! code for increment equal to 1
dmax = stdlib_cabs1(zx(1))
do i = 2,n
if (stdlib_cabs1(zx(i))>dmax) then
iamax = i
dmax = stdlib_cabs1(zx(i))
end if
end do
else
! code for increment not equal to 1
ix = 1
dmax = stdlib_cabs1(zx(1))
ix = ix + incx
do i = 2,n
if (stdlib_cabs1(zx(ix))>dmax) then
iamax = i
dmax = stdlib_cabs1(zx(ix))
end if
ix = ix + incx
end do
end if
return
end function stdlib${ii}$_i${ci}$amax
#:endfor
#:endfor
end module stdlib_linalg_blas_aux
fortran-lang-stdlib-0ede301/src/blas/stdlib_blas_constants.fypp 0000664 0001750 0001750 00000004130 15135654166 025152 0 ustar alastair alastair #:include "common.fypp"
#:for ck,ct,ci in REAL_KINDS_TYPES
module stdlib_blas_constants_${ck}$
use stdlib_linalg_constants
implicit none
real(${ck}$), parameter :: negone = -1.00_${ck}$
real(${ck}$), parameter :: zero = 0.00_${ck}$
real(${ck}$), parameter :: half = 0.50_${ck}$
real(${ck}$), parameter :: one = 1.00_${ck}$
real(${ck}$), parameter :: two = 2.00_${ck}$
real(${ck}$), parameter :: three = 3.00_${ck}$
real(${ck}$), parameter :: four = 4.00_${ck}$
real(${ck}$), parameter :: eight = 8.00_${ck}$
real(${ck}$), parameter :: ten = 10.00_${ck}$
complex(${ck}$), parameter :: czero = ( 0.0_${ck}$,0.0_${ck}$)
complex(${ck}$), parameter :: chalf = ( 0.5_${ck}$,0.0_${ck}$)
complex(${ck}$), parameter :: cone = ( 1.0_${ck}$,0.0_${ck}$)
complex(${ck}$), parameter :: cnegone = (-1.0_${ck}$,0.0_${ck}$)
! scaling constants
integer, parameter :: maxexp = maxexponent(zero)
integer, parameter :: minexp = minexponent(zero)
real(${ck}$), parameter :: rradix = real(radix(zero),${ck}$)
real(${ck}$), parameter :: ulp = epsilon(zero)
real(${ck}$), parameter :: eps = ulp*half
real(${ck}$), parameter :: safmin = rradix**max(minexp-1,1-maxexp)
real(${ck}$), parameter :: safmax = one/safmin
real(${ck}$), parameter :: smlnum = safmin/ulp
real(${ck}$), parameter :: bignum = safmax*ulp
real(${ck}$), parameter :: rtmin = sqrt(smlnum)
real(${ck}$), parameter :: rtmax = sqrt(bignum)
! Blue's scaling constants
! ssml>=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771
real(${ck}$), parameter :: tsml = rradix**ceiling((minexp-1)*half)
real(${ck}$), parameter :: tbig = rradix**floor((maxexp-digits(zero)+1)*half)
real(${ck}$), parameter :: ssml = rradix**(-floor((minexp-digits(zero))*half))
real(${ck}$), parameter :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half))
end module
#:endfor
fortran-lang-stdlib-0ede301/src/blas/CMakeLists.txt 0000664 0001750 0001750 00000001302 15135654166 022432 0 ustar alastair alastair set(blas_fppFiles
stdlib_blas_constants.fypp
stdlib_blas.fypp
stdlib_blas_level1.fypp
stdlib_blas_level2_ban.fypp
stdlib_blas_level2_gen.fypp
stdlib_blas_level2_pac.fypp
stdlib_blas_level2_sym.fypp
stdlib_blas_level2_tri.fypp
stdlib_blas_level3_gen.fypp
stdlib_blas_level3_sym.fypp
stdlib_blas_level3_tri.fypp
stdlib_linalg_blas_aux.fypp
)
set(blas_cppFiles
stdlib_linalg_blas.fypp
)
configure_stdlib_target(${PROJECT_NAME}_blas "" blas_fppFiles blas_cppFiles)
if(BLAS_FOUND)
target_link_libraries(${PROJECT_NAME}_blas PUBLIC "BLAS::BLAS")
endif()
target_link_libraries(${PROJECT_NAME}_blas PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_linalg_core)
fortran-lang-stdlib-0ede301/src/blas/stdlib_blas_level2_sym.fypp 0000664 0001750 0001750 00000126301 15135654166 025224 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_blas) stdlib_blas_level2_sym
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_ssymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! SSYMV 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
real(sp), intent(in) :: a(lda,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(sp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(uplo,'U')) then
! form y when a is stored in upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
do i = 1,j - 1
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + a(i,j)*x(i)
end do
y(j) = y(j) + temp1*a(j,j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
do 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
end do
y(jy) = y(jy) + temp1*a(j,j) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*a(j,j)
do i = j + 1,n
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + a(i,j)*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
y(jy) = y(jy) + temp1*a(j,j)
ix = jx
iy = jy
do 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)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_ssymv
pure module subroutine stdlib${ii}$_dsymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
real(dp), intent(in) :: a(lda,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(uplo,'U')) then
! form y when a is stored in upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
do i = 1,j - 1
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + a(i,j)*x(i)
end do
y(j) = y(j) + temp1*a(j,j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
do 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
end do
y(jy) = y(jy) + temp1*a(j,j) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*a(j,j)
do i = j + 1,n
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + a(i,j)*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
y(jy) = y(jy) + temp1*a(j,j)
ix = jx
iy = jy
do 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)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_dsymv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$symv(uplo,n,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_${rk}$
!! 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), x(*)
real(${rk}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(uplo,'U')) then
! form y when a is stored in upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
do i = 1,j - 1
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + a(i,j)*x(i)
end do
y(j) = y(j) + temp1*a(j,j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
do 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
end do
y(jy) = y(jy) + temp1*a(j,j) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
else
! form y when a is stored in lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*a(j,j)
do i = j + 1,n
y(i) = y(i) + temp1*a(i,j)
temp2 = temp2 + a(i,j)*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
y(jy) = y(jy) + temp1*a(j,j)
ix = jx
iy = jy
do 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)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$symv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssyr(uplo,n,alpha,x,incx,a,lda)
use stdlib_blas_constants_sp
!! SSYR performs the symmetric rank 1 operation
!! A := alpha*x*x**T + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n symmetric matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, lda, n
character, intent(in) :: uplo
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kx
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 (stdlib_lsame(uplo,'U')) then
! form a when a is stored in the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
do i = 1,j
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
end if
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = kx
iy = ky
do i = 1,j
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
end do
end if
else
! form a when a is stored in the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
do i = j,n
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
end if
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = jx
iy = jy
do i = j,n
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_ssyr2
pure module subroutine stdlib${ii}$_dsyr2(uplo,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_dp
!! DSYR2 performs the symmetric rank 2 operation
!! A := alpha*x*y**T + alpha*y*x**T + A,
!! where alpha is a scalar, x and y are n element vectors and A is an n
!! by n symmetric matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
real(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 (stdlib_lsame(uplo,'U')) then
! form a when a is stored in the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
do i = 1,j
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
end if
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = kx
iy = ky
do i = 1,j
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
end do
end if
else
! form a when a is stored in the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
do i = j,n
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
end if
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = jx
iy = jy
do i = j,n
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_dsyr2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$syr2(uplo,n,alpha,x,incx,y,incy,a,lda)
use stdlib_blas_constants_${rk}$
!! DSYR2: performs the symmetric rank 2 operation
!! A := alpha*x*y**T + alpha*y*x**T + A,
!! where alpha is a scalar, x and y are n element vectors and A is an n
!! by n symmetric matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, lda, n
character, intent(in) :: uplo
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
else if (lda0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 (stdlib_lsame(uplo,'U')) then
! form a when a is stored in the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
do i = 1,j
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
end if
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = kx
iy = ky
do i = 1,j
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
end do
end if
else
! form a when a is stored in the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
do i = j,n
a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2
end do
end if
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = jx
iy = jy
do i = j,n
a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$syr2
#:endif
#:endfor
#:endfor
end submodule stdlib_blas_level2_sym
fortran-lang-stdlib-0ede301/src/blas/stdlib_blas_level2_pac.fypp 0000664 0001750 0001750 00000344664 15135654166 025175 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_blas) stdlib_blas_level2_pac
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_sspmv(uplo,n,alpha,ap,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! SSPMV 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, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
real(sp), intent(in) :: ap(*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(sp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 6
else if (incy==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('SSPMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==zero).and. (beta==one))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>0) then
ky = 1
else
ky = 1 - (n-1)*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with one pass through ap.
! first form y := beta*y.
if (beta/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form y when ap contains the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
k = kk
do i = 1,j - 1
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(i)
k = k + 1
end do
y(j) = y(j) + temp1*ap(kk+j-1) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
do k = kk,kk + j - 2
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*ap(kk+j-1) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*ap(kk)
k = kk + 1
do i = j + 1,n
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(i)
k = k + 1
end do
y(j) = y(j) + alpha*temp2
kk = kk + (n-j+1)
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
y(jy) = y(jy) + temp1*ap(kk)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + (n-j+1)
end do
end if
end if
return
end subroutine stdlib${ii}$_sspmv
pure module subroutine stdlib${ii}$_dspmv(uplo,n,alpha,ap,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! DSPMV 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, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
real(dp), intent(in) :: ap(*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 6
else if (incy==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DSPMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==zero).and. (beta==one))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>0) then
ky = 1
else
ky = 1 - (n-1)*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with one pass through ap.
! first form y := beta*y.
if (beta/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form y when ap contains the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
k = kk
do i = 1,j - 1
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(i)
k = k + 1
end do
y(j) = y(j) + temp1*ap(kk+j-1) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
do k = kk,kk + j - 2
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*ap(kk+j-1) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*ap(kk)
k = kk + 1
do i = j + 1,n
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(i)
k = k + 1
end do
y(j) = y(j) + alpha*temp2
kk = kk + (n-j+1)
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
y(jy) = y(jy) + temp1*ap(kk)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + (n-j+1)
end do
end if
end if
return
end subroutine stdlib${ii}$_dspmv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$spmv(uplo,n,alpha,ap,x,incx,beta,y,incy)
use stdlib_blas_constants_${rk}$
!! DSPMV: 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, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
real(${rk}$), intent(in) :: ap(*), x(*)
real(${rk}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 6
else if (incy==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DSPMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==zero).and. (beta==one))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>0) then
ky = 1
else
ky = 1 - (n-1)*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with one pass through ap.
! first form y := beta*y.
if (beta/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form y when ap contains the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
k = kk
do i = 1,j - 1
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(i)
k = k + 1
end do
y(j) = y(j) + temp1*ap(kk+j-1) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
do k = kk,kk + j - 2
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*ap(kk+j-1) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*ap(kk)
k = kk + 1
do i = j + 1,n
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(i)
k = k + 1
end do
y(j) = y(j) + alpha*temp2
kk = kk + (n-j+1)
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
y(jy) = y(jy) + temp1*ap(kk)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + ap(k)*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + (n-j+1)
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$spmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! SSBMV 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, k, lda, n
character, intent(in) :: uplo
! Array Arguments
real(sp), intent(in) :: a(lda,*), x(*)
real(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(sp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (k<0) then
info = 3
else if (lda< (k+1)) then
info = 6
else if (incx==0) then
info = 8
else if (incy==0) then
info = 11
end if
if (info/=0) then
call stdlib${ii}$_xerbla('SSBMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==zero).and. (beta==one))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(uplo,'U')) then
! form y when upper triangle of a is stored.
kplus1 = k + 1
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
l = kplus1 - j
do i = max(1,j-k),j - 1
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + a(l+i,j)*x(i)
end do
y(j) = y(j) + temp1*a(kplus1,j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
l = kplus1 - j
do 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
end do
y(jy) = y(jy) + temp1*a(kplus1,j) + alpha*temp2
jx = jx + incx
jy = jy + incy
if (j>k) then
kx = kx + incx
ky = ky + incy
end if
end do
end if
else
! form y when lower triangle of a is stored.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*a(1,j)
l = 1 - j
do i = j + 1,min(n,j+k)
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + a(l+i,j)*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do 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 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)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_ssbmv
pure module subroutine stdlib${ii}$_dsbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, k, lda, n
character, intent(in) :: uplo
! Array Arguments
real(dp), intent(in) :: a(lda,*), x(*)
real(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (k<0) then
info = 3
else if (lda< (k+1)) then
info = 6
else if (incx==0) then
info = 8
else if (incy==0) then
info = 11
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DSBMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==zero).and. (beta==one))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(uplo,'U')) then
! form y when upper triangle of a is stored.
kplus1 = k + 1
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
l = kplus1 - j
do i = max(1,j-k),j - 1
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + a(l+i,j)*x(i)
end do
y(j) = y(j) + temp1*a(kplus1,j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
l = kplus1 - j
do 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
end do
y(jy) = y(jy) + temp1*a(kplus1,j) + alpha*temp2
jx = jx + incx
jy = jy + incy
if (j>k) then
kx = kx + incx
ky = ky + incy
end if
end do
end if
else
! form y when lower triangle of a is stored.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*a(1,j)
l = 1 - j
do i = j + 1,min(n,j+k)
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + a(l+i,j)*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do 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 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)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_dsbmv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy)
use stdlib_blas_constants_${rk}$
!! 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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, k, lda, n
character, intent(in) :: uplo
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*), x(*)
real(${rk}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (k<0) then
info = 3
else if (lda< (k+1)) then
info = 6
else if (incx==0) then
info = 8
else if (incy==0) then
info = 11
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DSBMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==zero).and. (beta==one))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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/=one) then
if (incy==1) then
if (beta==zero) then
do i = 1,n
y(i) = zero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==zero) then
do i = 1,n
y(iy) = zero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==zero) return
if (stdlib_lsame(uplo,'U')) then
! form y when upper triangle of a is stored.
kplus1 = k + 1
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
l = kplus1 - j
do i = max(1,j-k),j - 1
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + a(l+i,j)*x(i)
end do
y(j) = y(j) + temp1*a(kplus1,j) + alpha*temp2
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = zero
ix = kx
iy = ky
l = kplus1 - j
do 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
end do
y(jy) = y(jy) + temp1*a(kplus1,j) + alpha*temp2
jx = jx + incx
jy = jy + incy
if (j>k) then
kx = kx + incx
ky = ky + incy
end if
end do
end if
else
! form y when lower triangle of a is stored.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = zero
y(j) = y(j) + temp1*a(1,j)
l = 1 - j
do i = j + 1,min(n,j+k)
y(i) = y(i) + temp1*a(l+i,j)
temp2 = temp2 + a(l+i,j)*x(i)
end do
y(j) = y(j) + alpha*temp2
end do
else
jx = kx
jy = ky
do 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 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)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$sbmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sspr(uplo,n,alpha,x,incx,ap)
use stdlib_blas_constants_sp
!! SSPR performs the symmetric rank 1 operation
!! A := alpha*x*x**T + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: uplo
! Array Arguments
real(sp), intent(inout) :: ap(*)
real(sp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
end if
if (info/=0) then
call stdlib${ii}$_xerbla('SSPR ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==zero)) return
! set the start point in x if the increment is not unity.
if (incx<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with one pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = alpha*x(j)
k = kk
do i = 1,j
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = alpha*x(jx)
ix = kx
do k = kk,kk + j - 1
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = alpha*x(j)
k = kk
do i = j,n
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
end if
kk = kk + n - j + 1
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = alpha*x(jx)
ix = jx
do k = kk,kk + n - j
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
end if
jx = jx + incx
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_sspr
pure module subroutine stdlib${ii}$_dspr(uplo,n,alpha,x,incx,ap)
use stdlib_blas_constants_dp
!! DSPR performs the symmetric rank 1 operation
!! A := alpha*x*x**T + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: uplo
! Array Arguments
real(dp), intent(inout) :: ap(*)
real(dp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
real(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DSPR ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==zero)) return
! set the start point in x if the increment is not unity.
if (incx<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with one pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = alpha*x(j)
k = kk
do i = 1,j
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = alpha*x(jx)
ix = kx
do k = kk,kk + j - 1
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = alpha*x(j)
k = kk
do i = j,n
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
end if
kk = kk + n - j + 1
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = alpha*x(jx)
ix = jx
do k = kk,kk + n - j
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
end if
jx = jx + incx
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_dspr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$spr(uplo,n,alpha,x,incx,ap)
use stdlib_blas_constants_${rk}$
!! DSPR: performs the symmetric rank 1 operation
!! A := alpha*x*x**T + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: uplo
! Array Arguments
real(${rk}$), intent(inout) :: ap(*)
real(${rk}$), intent(in) :: x(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DSPR ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==zero)) return
! set the start point in x if the increment is not unity.
if (incx<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with one pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = alpha*x(j)
k = kk
do i = 1,j
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = alpha*x(jx)
ix = kx
do k = kk,kk + j - 1
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = alpha*x(j)
k = kk
do i = j,n
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
end if
kk = kk + n - j + 1
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = alpha*x(jx)
ix = jx
do k = kk,kk + n - j
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
end if
jx = jx + incx
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$spr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sspr2(uplo,n,alpha,x,incx,y,incy,ap)
use stdlib_blas_constants_sp
!! SSPR2 performs the symmetric rank 2 operation
!! A := alpha*x*y**T + alpha*y*x**T + A,
!! where alpha is a scalar, x and y are n element vectors and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
real(sp), intent(inout) :: ap(*)
real(sp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
real(sp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('SSPR2 ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==zero)) return
! set up the start points in x and y if the increments are not both
! unity.
if ((incx/=1) .or. (incy/=1)) then
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 the array ap
! are accessed sequentially with one pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
k = kk
do i = 1,j
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
end if
kk = kk + j
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = kx
iy = ky
do k = kk,kk + j - 1
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
k = kk
do i = j,n
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
end if
kk = kk + n - j + 1
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = jx
iy = jy
do k = kk,kk + n - j
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_sspr2
pure module subroutine stdlib${ii}$_dspr2(uplo,n,alpha,x,incx,y,incy,ap)
use stdlib_blas_constants_dp
!! DSPR2 performs the symmetric rank 2 operation
!! A := alpha*x*y**T + alpha*y*x**T + A,
!! where alpha is a scalar, x and y are n element vectors and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
real(dp), intent(inout) :: ap(*)
real(dp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
real(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DSPR2 ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==zero)) return
! set up the start points in x and y if the increments are not both
! unity.
if ((incx/=1) .or. (incy/=1)) then
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 the array ap
! are accessed sequentially with one pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
k = kk
do i = 1,j
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
end if
kk = kk + j
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = kx
iy = ky
do k = kk,kk + j - 1
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
k = kk
do i = j,n
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
end if
kk = kk + n - j + 1
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = jx
iy = jy
do k = kk,kk + n - j
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_dspr2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$spr2(uplo,n,alpha,x,incx,y,incy,ap)
use stdlib_blas_constants_${rk}$
!! DSPR2: performs the symmetric rank 2 operation
!! A := alpha*x*y**T + alpha*y*x**T + A,
!! where alpha is a scalar, x and y are n element vectors and A is an
!! n by n symmetric matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
real(${rk}$), intent(inout) :: ap(*)
real(${rk}$), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DSPR2 ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==zero)) return
! set up the start points in x and y if the increments are not both
! unity.
if ((incx/=1) .or. (incy/=1)) then
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 the array ap
! are accessed sequentially with one pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
k = kk
do i = 1,j
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
end if
kk = kk + j
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = kx
iy = ky
do k = kk,kk + j - 1
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=zero) .or. (y(j)/=zero)) then
temp1 = alpha*y(j)
temp2 = alpha*x(j)
k = kk
do i = j,n
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
end if
kk = kk + n - j + 1
end do
else
do j = 1,n
if ((x(jx)/=zero) .or. (y(jy)/=zero)) then
temp1 = alpha*y(jy)
temp2 = alpha*x(jx)
ix = jx
iy = jy
do k = kk,kk + n - j
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
end if
jx = jx + incx
jy = jy + incy
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$spr2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chpmv(uplo,n,alpha,ap,x,incx,beta,y,incy)
use stdlib_blas_constants_sp
!! CHPMV 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 hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(in) :: ap(*), x(*)
complex(sp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! Intrinsic Functions
intrinsic :: conjg,real
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 6
else if (incy==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CHPMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==czero).and. (beta==cone))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>0) then
ky = 1
else
ky = 1 - (n-1)*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form y when ap contains the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
k = kk
do i = 1,j - 1
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(i)
k = k + 1
end do
y(j) = y(j) + temp1*real(ap(kk+j-1),KIND=sp) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
do k = kk,kk + j - 2
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(ap(kk+j-1),KIND=sp) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(ap(kk),KIND=sp)
k = kk + 1
do i = j + 1,n
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(i)
k = k + 1
end do
y(j) = y(j) + alpha*temp2
kk = kk + (n-j+1)
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(ap(kk),KIND=sp)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + (n-j+1)
end do
end if
end if
return
end subroutine stdlib${ii}$_chpmv
pure module subroutine stdlib${ii}$_zhpmv(uplo,n,alpha,ap,x,incx,beta,y,incy)
use stdlib_blas_constants_dp
!! ZHPMV 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 hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(in) :: ap(*), x(*)
complex(dp), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! Intrinsic Functions
intrinsic :: real,conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 6
else if (incy==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZHPMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==czero).and. (beta==cone))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>0) then
ky = 1
else
ky = 1 - (n-1)*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form y when ap contains the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
k = kk
do i = 1,j - 1
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(i)
k = k + 1
end do
y(j) = y(j) + temp1*real(ap(kk+j-1),KIND=dp) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
do k = kk,kk + j - 2
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(ap(kk+j-1),KIND=dp) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(ap(kk),KIND=dp)
k = kk + 1
do i = j + 1,n
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(i)
k = k + 1
end do
y(j) = y(j) + alpha*temp2
kk = kk + (n-j+1)
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(ap(kk),KIND=dp)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + (n-j+1)
end do
end if
end if
return
end subroutine stdlib${ii}$_zhpmv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hpmv(uplo,n,alpha,ap,x,incx,beta,y,incy)
use stdlib_blas_constants_${ck}$
!! ZHPMV: 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 hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(in) :: ap(*), x(*)
complex(${ck}$), intent(inout) :: y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! Intrinsic Functions
intrinsic :: real,conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 6
else if (incy==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZHPMV ',info)
return
end if
! quick return if possible.
if ((n==0) .or. ((alpha==czero).and. (beta==cone))) return
! set up the start points in x and y.
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>0) then
ky = 1
else
ky = 1 - (n-1)*incy
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
! first form y := beta*y.
if (beta/=cone) then
if (incy==1) then
if (beta==czero) then
do i = 1,n
y(i) = czero
end do
else
do i = 1,n
y(i) = beta*y(i)
end do
end if
else
iy = ky
if (beta==czero) then
do i = 1,n
y(iy) = czero
iy = iy + incy
end do
else
do i = 1,n
y(iy) = beta*y(iy)
iy = iy + incy
end do
end if
end if
end if
if (alpha==czero) return
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form y when ap contains the upper triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
k = kk
do i = 1,j - 1
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(i)
k = k + 1
end do
y(j) = y(j) + temp1*real(ap(kk+j-1),KIND=${ck}$) + alpha*temp2
kk = kk + j
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
ix = kx
iy = ky
do k = kk,kk + j - 2
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(ix)
ix = ix + incx
iy = iy + incy
end do
y(jy) = y(jy) + temp1*real(ap(kk+j-1),KIND=${ck}$) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form y when ap contains the lower triangle.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
temp1 = alpha*x(j)
temp2 = czero
y(j) = y(j) + temp1*real(ap(kk),KIND=${ck}$)
k = kk + 1
do i = j + 1,n
y(i) = y(i) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(i)
k = k + 1
end do
y(j) = y(j) + alpha*temp2
kk = kk + (n-j+1)
end do
else
jx = kx
jy = ky
do j = 1,n
temp1 = alpha*x(jx)
temp2 = czero
y(jy) = y(jy) + temp1*real(ap(kk),KIND=${ck}$)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
y(iy) = y(iy) + temp1*ap(k)
temp2 = temp2 + conjg(ap(k))*x(ix)
end do
y(jy) = y(jy) + alpha*temp2
jx = jx + incx
jy = jy + incy
kk = kk + (n-j+1)
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$hpmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chpr(uplo,n,alpha,x,incx,ap)
use stdlib_blas_constants_sp
!! CHPR performs the hermitian rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(inout) :: ap(*)
complex(sp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
! Intrinsic Functions
intrinsic :: conjg,real
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CHPR ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==real(czero,KIND=sp))) return
! set the start point in x if the increment is not unity.
if (incx<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = alpha*conjg(x(j))
k = kk
do i = 1,j - 1
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=sp) + real(x(j)*temp,KIND=sp)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=sp)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = alpha*conjg(x(jx))
ix = kx
do k = kk,kk + j - 2
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=sp) + real(x(jx)*temp,KIND=sp)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=sp)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = alpha*conjg(x(j))
ap(kk) = real(ap(kk),KIND=sp) + real(temp*x(j),KIND=sp)
k = kk + 1
do i = j + 1,n
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
else
ap(kk) = real(ap(kk),KIND=sp)
end if
kk = kk + n - j + 1
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = alpha*conjg(x(jx))
ap(kk) = real(ap(kk),KIND=sp) + real(temp*x(jx),KIND=sp)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
ap(k) = ap(k) + x(ix)*temp
end do
else
ap(kk) = real(ap(kk),KIND=sp)
end if
jx = jx + incx
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_chpr
pure module subroutine stdlib${ii}$_zhpr(uplo,n,alpha,x,incx,ap)
use stdlib_blas_constants_dp
!! ZHPR performs the hermitian rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(inout) :: ap(*)
complex(dp), intent(in) :: x(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
! Intrinsic Functions
intrinsic :: real,conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZHPR ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==real(czero,KIND=dp))) return
! set the start point in x if the increment is not unity.
if (incx<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = alpha*conjg(x(j))
k = kk
do i = 1,j - 1
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=dp) + real(x(j)*temp,KIND=dp)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=dp)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = alpha*conjg(x(jx))
ix = kx
do k = kk,kk + j - 2
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=dp) + real(x(jx)*temp,KIND=dp)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=dp)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = alpha*conjg(x(j))
ap(kk) = real(ap(kk),KIND=dp) + real(temp*x(j),KIND=dp)
k = kk + 1
do i = j + 1,n
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
else
ap(kk) = real(ap(kk),KIND=dp)
end if
kk = kk + n - j + 1
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = alpha*conjg(x(jx))
ap(kk) = real(ap(kk),KIND=dp) + real(temp*x(jx),KIND=dp)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
ap(k) = ap(k) + x(ix)*temp
end do
else
ap(kk) = real(ap(kk),KIND=dp)
end if
jx = jx + incx
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_zhpr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hpr(uplo,n,alpha,x,incx,ap)
use stdlib_blas_constants_${ck}$
!! ZHPR: performs the hermitian rank 1 operation
!! A := alpha*x*x**H + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${ck}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(inout) :: ap(*)
complex(${ck}$), intent(in) :: x(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
! Intrinsic Functions
intrinsic :: real,conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZHPR ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==real(czero,KIND=${ck}$))) return
! set the start point in x if the increment is not unity.
if (incx<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of the array ap
! are accessed sequentially with cone pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = alpha*conjg(x(j))
k = kk
do i = 1,j - 1
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) + real(x(j)*temp,KIND=${ck}$)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = alpha*conjg(x(jx))
ix = kx
do k = kk,kk + j - 2
ap(k) = ap(k) + x(ix)*temp
ix = ix + incx
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) + real(x(jx)*temp,KIND=${ck}$)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = alpha*conjg(x(j))
ap(kk) = real(ap(kk),KIND=${ck}$) + real(temp*x(j),KIND=${ck}$)
k = kk + 1
do i = j + 1,n
ap(k) = ap(k) + x(i)*temp
k = k + 1
end do
else
ap(kk) = real(ap(kk),KIND=${ck}$)
end if
kk = kk + n - j + 1
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = alpha*conjg(x(jx))
ap(kk) = real(ap(kk),KIND=${ck}$) + real(temp*x(jx),KIND=${ck}$)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
ap(k) = ap(k) + x(ix)*temp
end do
else
ap(kk) = real(ap(kk),KIND=${ck}$)
end if
jx = jx + incx
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$hpr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chpr2(uplo,n,alpha,x,incx,y,incy,ap)
use stdlib_blas_constants_sp
!! CHPR2 performs the hermitian rank 2 operation
!! A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
!! where alpha is a scalar, x and y are n element vectors and A is an
!! n by n hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
complex(sp), intent(inout) :: ap(*)
complex(sp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! Intrinsic Functions
intrinsic :: conjg,real
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CHPR2 ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==czero)) return
! set up the start points in x and y if the increments are not both
! unity.
if ((incx/=1) .or. (incy/=1)) then
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 the array ap
! are accessed sequentially with cone pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
k = kk
do i = 1,j - 1
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=sp) +real(x(j)*temp1+y(j)*temp2,&
KIND=sp)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=sp)
end if
kk = kk + j
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ix = kx
iy = ky
do k = kk,kk + j - 2
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=sp) +real(x(jx)*temp1+y(jy)*temp2,&
KIND=sp)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=sp)
end if
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
ap(kk) = real(ap(kk),KIND=sp) +real(x(j)*temp1+y(j)*temp2,KIND=sp)
k = kk + 1
do i = j + 1,n
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
else
ap(kk) = real(ap(kk),KIND=sp)
end if
kk = kk + n - j + 1
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ap(kk) = real(ap(kk),KIND=sp) +real(x(jx)*temp1+y(jy)*temp2,KIND=sp)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
end do
else
ap(kk) = real(ap(kk),KIND=sp)
end if
jx = jx + incx
jy = jy + incy
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_chpr2
pure module subroutine stdlib${ii}$_zhpr2(uplo,n,alpha,x,incx,y,incy,ap)
use stdlib_blas_constants_dp
!! ZHPR2 performs the hermitian rank 2 operation
!! A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
!! where alpha is a scalar, x and y are n element vectors and A is an
!! n by n hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(dp), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
complex(dp), intent(inout) :: ap(*)
complex(dp), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! Intrinsic Functions
intrinsic :: real,conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZHPR2 ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==czero)) return
! set up the start points in x and y if the increments are not both
! unity.
if ((incx/=1) .or. (incy/=1)) then
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 the array ap
! are accessed sequentially with cone pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
k = kk
do i = 1,j - 1
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=dp) +real(x(j)*temp1+y(j)*temp2,&
KIND=dp)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=dp)
end if
kk = kk + j
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ix = kx
iy = ky
do k = kk,kk + j - 2
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=dp) +real(x(jx)*temp1+y(jy)*temp2,&
KIND=dp)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=dp)
end if
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
ap(kk) = real(ap(kk),KIND=dp) +real(x(j)*temp1+y(j)*temp2,KIND=dp)
k = kk + 1
do i = j + 1,n
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
else
ap(kk) = real(ap(kk),KIND=dp)
end if
kk = kk + n - j + 1
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ap(kk) = real(ap(kk),KIND=dp) +real(x(jx)*temp1+y(jy)*temp2,KIND=dp)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
end do
else
ap(kk) = real(ap(kk),KIND=dp)
end if
jx = jx + incx
jy = jy + incy
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_zhpr2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hpr2(uplo,n,alpha,x,incx,y,incy,ap)
use stdlib_blas_constants_${ck}$
!! ZHPR2: performs the hermitian rank 2 operation
!! A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
!! where alpha is a scalar, x and y are n element vectors and A is an
!! n by n hermitian matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
complex(${ck}$), intent(in) :: alpha
integer(${ik}$), intent(in) :: incx, incy, n
character, intent(in) :: uplo
! Array Arguments
complex(${ck}$), intent(inout) :: ap(*)
complex(${ck}$), intent(in) :: x(*), y(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp1, temp2
integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky
! Intrinsic Functions
intrinsic :: real,conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (n<0) then
info = 2
else if (incx==0) then
info = 5
else if (incy==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZHPR2 ',info)
return
end if
! quick return if possible.
if ((n==0) .or. (alpha==czero)) return
! set up the start points in x and y if the increments are not both
! unity.
if ((incx/=1) .or. (incy/=1)) then
if (incx>0) then
kx = 1
else
kx = 1 - (n-1)*incx
end if
if (incy>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 the array ap
! are accessed sequentially with cone pass through ap.
kk = 1
if (stdlib_lsame(uplo,'U')) then
! form a when upper triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
k = kk
do i = 1,j - 1
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) +real(x(j)*temp1+y(j)*temp2,&
KIND=${ck}$)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$)
end if
kk = kk + j
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ix = kx
iy = ky
do k = kk,kk + j - 2
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
ix = ix + incx
iy = iy + incy
end do
ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) +real(x(jx)*temp1+y(jy)*temp2,&
KIND=${ck}$)
else
ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$)
end if
jx = jx + incx
jy = jy + incy
kk = kk + j
end do
end if
else
! form a when lower triangle is stored in ap.
if ((incx==1) .and. (incy==1)) then
do j = 1,n
if ((x(j)/=czero) .or. (y(j)/=czero)) then
temp1 = alpha*conjg(y(j))
temp2 = conjg(alpha*x(j))
ap(kk) = real(ap(kk),KIND=${ck}$) +real(x(j)*temp1+y(j)*temp2,KIND=${ck}$)
k = kk + 1
do i = j + 1,n
ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2
k = k + 1
end do
else
ap(kk) = real(ap(kk),KIND=${ck}$)
end if
kk = kk + n - j + 1
end do
else
do j = 1,n
if ((x(jx)/=czero) .or. (y(jy)/=czero)) then
temp1 = alpha*conjg(y(jy))
temp2 = conjg(alpha*x(jx))
ap(kk) = real(ap(kk),KIND=${ck}$) +real(x(jx)*temp1+y(jy)*temp2,KIND=${ck}$)
ix = jx
iy = jy
do k = kk + 1,kk + n - j
ix = ix + incx
iy = iy + incy
ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2
end do
else
ap(kk) = real(ap(kk),KIND=${ck}$)
end if
jx = jx + incx
jy = jy + incy
kk = kk + n - j + 1
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$hpr2
#:endif
#:endfor
#:endfor
end submodule stdlib_blas_level2_pac
fortran-lang-stdlib-0ede301/src/blas/stdlib_blas_level2_tri.fypp 0000664 0001750 0001750 00001105063 15135654166 025215 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_blas) stdlib_blas_level2_tri
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_strmv(uplo,trans,diag,n,a,lda,x,incx)
use stdlib_blas_constants_sp
!! STRMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kx
logical(lk) :: nounit
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (ldak) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(1,j)
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*a(1,j)
end if
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
else
! form x := a**t*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = kplus1 - j
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(i)
end do
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
kx = kx - incx
ix = kx
l = kplus1 - j
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(ix)
ix = ix - incx
end do
x(jx) = temp
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
temp = x(j)
l = 1 - j
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(i)
end do
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
kx = kx + incx
ix = kx
l = 1 - j
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(ix)
ix = ix + incx
end do
x(jx) = temp
jx = jx + incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_stbmv
pure module subroutine stdlib${ii}$_dtbmv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_dp
!! DTBMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular band matrix, with ( k + 1 ) diagonals.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: nounit
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DTBMV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=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 (stdlib_lsame(trans,'N')) then
! form x := a*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = x(j)
l = kplus1 - j
do i = max(1,j-k),j - 1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(kplus1,j)
end if
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
l = kplus1 - j
do i = max(1,j-k),j - 1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*a(kplus1,j)
end if
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(1,j)
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*a(1,j)
end if
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
else
! form x := a**t*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = kplus1 - j
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(i)
end do
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
kx = kx - incx
ix = kx
l = kplus1 - j
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(ix)
ix = ix - incx
end do
x(jx) = temp
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
temp = x(j)
l = 1 - j
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(i)
end do
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
kx = kx + incx
ix = kx
l = 1 - j
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(ix)
ix = ix + incx
end do
x(jx) = temp
jx = jx + incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_dtbmv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tbmv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_${rk}$
!! DTBMV: performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular band matrix, with ( k + 1 ) diagonals.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: nounit
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DTBMV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=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 (stdlib_lsame(trans,'N')) then
! form x := a*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = x(j)
l = kplus1 - j
do i = max(1,j-k),j - 1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(kplus1,j)
end if
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
l = kplus1 - j
do i = max(1,j-k),j - 1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*a(kplus1,j)
end if
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(1,j)
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*a(1,j)
end if
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
else
! form x := a**t*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = kplus1 - j
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(i)
end do
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
kx = kx - incx
ix = kx
l = kplus1 - j
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(ix)
ix = ix - incx
end do
x(jx) = temp
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
temp = x(j)
l = 1 - j
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(i)
end do
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
kx = kx + incx
ix = kx
l = 1 - j
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(ix)
ix = ix + incx
end do
x(jx) = temp
jx = jx + incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$tbmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctbmv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_sp
!! CTBMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular band matrix, with ( k + 1 ) diagonals.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CTBMV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through a.
if (stdlib_lsame(trans,'N')) then
! form x := a*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = x(j)
l = kplus1 - j
do i = max(1,j-k),j - 1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(kplus1,j)
end if
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
l = kplus1 - j
do i = max(1,j-k),j - 1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*a(kplus1,j)
end if
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(1,j)
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*a(1,j)
end if
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
else
! form x := a**t*x or x := a**h*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = kplus1 - j
if (noconj) then
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(i)
end do
else
if (nounit) temp = temp*conjg(a(kplus1,j))
do i = j - 1,max(1,j-k),-1
temp = temp + conjg(a(l+i,j))*x(i)
end do
end if
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
kx = kx - incx
ix = kx
l = kplus1 - j
if (noconj) then
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(ix)
ix = ix - incx
end do
else
if (nounit) temp = temp*conjg(a(kplus1,j))
do i = j - 1,max(1,j-k),-1
temp = temp + conjg(a(l+i,j))*x(ix)
ix = ix - incx
end do
end if
x(jx) = temp
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
temp = x(j)
l = 1 - j
if (noconj) then
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(i)
end do
else
if (nounit) temp = temp*conjg(a(1,j))
do i = j + 1,min(n,j+k)
temp = temp + conjg(a(l+i,j))*x(i)
end do
end if
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
kx = kx + incx
ix = kx
l = 1 - j
if (noconj) then
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(ix)
ix = ix + incx
end do
else
if (nounit) temp = temp*conjg(a(1,j))
do i = j + 1,min(n,j+k)
temp = temp + conjg(a(l+i,j))*x(ix)
ix = ix + incx
end do
end if
x(jx) = temp
jx = jx + incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_ctbmv
pure module subroutine stdlib${ii}$_ztbmv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_dp
!! ZTBMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular band matrix, with ( k + 1 ) diagonals.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZTBMV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through a.
if (stdlib_lsame(trans,'N')) then
! form x := a*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = x(j)
l = kplus1 - j
do i = max(1,j-k),j - 1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(kplus1,j)
end if
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
l = kplus1 - j
do i = max(1,j-k),j - 1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*a(kplus1,j)
end if
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(1,j)
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*a(1,j)
end if
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
else
! form x := a**t*x or x := a**h*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = kplus1 - j
if (noconj) then
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(i)
end do
else
if (nounit) temp = temp*conjg(a(kplus1,j))
do i = j - 1,max(1,j-k),-1
temp = temp + conjg(a(l+i,j))*x(i)
end do
end if
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
kx = kx - incx
ix = kx
l = kplus1 - j
if (noconj) then
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(ix)
ix = ix - incx
end do
else
if (nounit) temp = temp*conjg(a(kplus1,j))
do i = j - 1,max(1,j-k),-1
temp = temp + conjg(a(l+i,j))*x(ix)
ix = ix - incx
end do
end if
x(jx) = temp
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
temp = x(j)
l = 1 - j
if (noconj) then
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(i)
end do
else
if (nounit) temp = temp*conjg(a(1,j))
do i = j + 1,min(n,j+k)
temp = temp + conjg(a(l+i,j))*x(i)
end do
end if
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
kx = kx + incx
ix = kx
l = 1 - j
if (noconj) then
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(ix)
ix = ix + incx
end do
else
if (nounit) temp = temp*conjg(a(1,j))
do i = j + 1,min(n,j+k)
temp = temp + conjg(a(l+i,j))*x(ix)
ix = ix + incx
end do
end if
x(jx) = temp
jx = jx + incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_ztbmv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tbmv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_${ck}$
!! ZTBMV: performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular band matrix, with ( k + 1 ) diagonals.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZTBMV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of a are
! accessed sequentially with cone pass through a.
if (stdlib_lsame(trans,'N')) then
! form x := a*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = x(j)
l = kplus1 - j
do i = max(1,j-k),j - 1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(kplus1,j)
end if
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
l = kplus1 - j
do i = max(1,j-k),j - 1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*a(kplus1,j)
end if
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(i) = x(i) + temp*a(l+i,j)
end do
if (nounit) x(j) = x(j)*a(1,j)
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
x(ix) = x(ix) + temp*a(l+i,j)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*a(1,j)
end if
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
else
! form x := a**t*x or x := a**h*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = kplus1 - j
if (noconj) then
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(i)
end do
else
if (nounit) temp = temp*conjg(a(kplus1,j))
do i = j - 1,max(1,j-k),-1
temp = temp + conjg(a(l+i,j))*x(i)
end do
end if
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
kx = kx - incx
ix = kx
l = kplus1 - j
if (noconj) then
if (nounit) temp = temp*a(kplus1,j)
do i = j - 1,max(1,j-k),-1
temp = temp + a(l+i,j)*x(ix)
ix = ix - incx
end do
else
if (nounit) temp = temp*conjg(a(kplus1,j))
do i = j - 1,max(1,j-k),-1
temp = temp + conjg(a(l+i,j))*x(ix)
ix = ix - incx
end do
end if
x(jx) = temp
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
temp = x(j)
l = 1 - j
if (noconj) then
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(i)
end do
else
if (nounit) temp = temp*conjg(a(1,j))
do i = j + 1,min(n,j+k)
temp = temp + conjg(a(l+i,j))*x(i)
end do
end if
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
kx = kx + incx
ix = kx
l = 1 - j
if (noconj) then
if (nounit) temp = temp*a(1,j)
do i = j + 1,min(n,j+k)
temp = temp + a(l+i,j)*x(ix)
ix = ix + incx
end do
else
if (nounit) temp = temp*conjg(a(1,j))
do i = j + 1,min(n,j+k)
temp = temp + conjg(a(l+i,j))*x(ix)
ix = ix + incx
end do
end if
x(jx) = temp
jx = jx + incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$tbmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stpmv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_sp
!! STPMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(sp), intent(in) :: ap(*)
real(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: nounit
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('STPMV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with one pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x:= a*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = x(j)
k = kk
do i = 1,j - 1
x(i) = x(i) + temp*ap(k)
k = k + 1
end do
if (nounit) x(j) = x(j)*ap(kk+j-1)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
x(ix) = x(ix) + temp*ap(k)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*ap(kk+j-1)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
temp = x(j)
k = kk
do i = n,j + 1,-1
x(i) = x(i) + temp*ap(k)
k = k - 1
end do
if (nounit) x(j) = x(j)*ap(kk-n+j)
end if
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
x(ix) = x(ix) + temp*ap(k)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*ap(kk-n+j)
end if
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
else
! form x := a**t*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
if (nounit) temp = temp*ap(kk)
k = kk - 1
do i = j - 1,1,-1
temp = temp + ap(k)*x(i)
k = k - 1
end do
x(j) = temp
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
temp = x(jx)
ix = jx
if (nounit) temp = temp*ap(kk)
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + ap(k)*x(ix)
end do
x(jx) = temp
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
if (nounit) temp = temp*ap(kk)
k = kk + 1
do i = j + 1,n
temp = temp + ap(k)*x(i)
k = k + 1
end do
x(j) = temp
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = jx
if (nounit) temp = temp*ap(kk)
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + ap(k)*x(ix)
end do
x(jx) = temp
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_stpmv
pure module subroutine stdlib${ii}$_dtpmv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_dp
!! DTPMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(dp), intent(in) :: ap(*)
real(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: nounit
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DTPMV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with one pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x:= a*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = x(j)
k = kk
do i = 1,j - 1
x(i) = x(i) + temp*ap(k)
k = k + 1
end do
if (nounit) x(j) = x(j)*ap(kk+j-1)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
x(ix) = x(ix) + temp*ap(k)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*ap(kk+j-1)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
temp = x(j)
k = kk
do i = n,j + 1,-1
x(i) = x(i) + temp*ap(k)
k = k - 1
end do
if (nounit) x(j) = x(j)*ap(kk-n+j)
end if
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
x(ix) = x(ix) + temp*ap(k)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*ap(kk-n+j)
end if
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
else
! form x := a**t*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
if (nounit) temp = temp*ap(kk)
k = kk - 1
do i = j - 1,1,-1
temp = temp + ap(k)*x(i)
k = k - 1
end do
x(j) = temp
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
temp = x(jx)
ix = jx
if (nounit) temp = temp*ap(kk)
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + ap(k)*x(ix)
end do
x(jx) = temp
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
if (nounit) temp = temp*ap(kk)
k = kk + 1
do i = j + 1,n
temp = temp + ap(k)*x(i)
k = k + 1
end do
x(j) = temp
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = jx
if (nounit) temp = temp*ap(kk)
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + ap(k)*x(ix)
end do
x(jx) = temp
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_dtpmv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tpmv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_${rk}$
!! DTPMV: performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: nounit
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DTPMV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with one pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x:= a*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
temp = x(j)
k = kk
do i = 1,j - 1
x(i) = x(i) + temp*ap(k)
k = k + 1
end do
if (nounit) x(j) = x(j)*ap(kk+j-1)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
x(ix) = x(ix) + temp*ap(k)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*ap(kk+j-1)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
temp = x(j)
k = kk
do i = n,j + 1,-1
x(i) = x(i) + temp*ap(k)
k = k - 1
end do
if (nounit) x(j) = x(j)*ap(kk-n+j)
end if
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=zero) then
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
x(ix) = x(ix) + temp*ap(k)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*ap(kk-n+j)
end if
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
else
! form x := a**t*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
if (nounit) temp = temp*ap(kk)
k = kk - 1
do i = j - 1,1,-1
temp = temp + ap(k)*x(i)
k = k - 1
end do
x(j) = temp
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
temp = x(jx)
ix = jx
if (nounit) temp = temp*ap(kk)
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + ap(k)*x(ix)
end do
x(jx) = temp
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
if (nounit) temp = temp*ap(kk)
k = kk + 1
do i = j + 1,n
temp = temp + ap(k)*x(i)
k = k + 1
end do
x(j) = temp
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = jx
if (nounit) temp = temp*ap(kk)
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + ap(k)*x(ix)
end do
x(jx) = temp
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$tpmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctpmv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_sp
!! CTPMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(sp), intent(in) :: ap(*)
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CTPMV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with cone pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x:= a*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = x(j)
k = kk
do i = 1,j - 1
x(i) = x(i) + temp*ap(k)
k = k + 1
end do
if (nounit) x(j) = x(j)*ap(kk+j-1)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
x(ix) = x(ix) + temp*ap(k)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*ap(kk+j-1)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
temp = x(j)
k = kk
do i = n,j + 1,-1
x(i) = x(i) + temp*ap(k)
k = k - 1
end do
if (nounit) x(j) = x(j)*ap(kk-n+j)
end if
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
x(ix) = x(ix) + temp*ap(k)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*ap(kk-n+j)
end if
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
else
! form x := a**t*x or x := a**h*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk - 1
if (noconj) then
if (nounit) temp = temp*ap(kk)
do i = j - 1,1,-1
temp = temp + ap(k)*x(i)
k = k - 1
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do i = j - 1,1,-1
temp = temp + conjg(ap(k))*x(i)
k = k - 1
end do
end if
x(j) = temp
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
temp = x(jx)
ix = jx
if (noconj) then
if (nounit) temp = temp*ap(kk)
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + ap(k)*x(ix)
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + conjg(ap(k))*x(ix)
end do
end if
x(jx) = temp
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk + 1
if (noconj) then
if (nounit) temp = temp*ap(kk)
do i = j + 1,n
temp = temp + ap(k)*x(i)
k = k + 1
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do i = j + 1,n
temp = temp + conjg(ap(k))*x(i)
k = k + 1
end do
end if
x(j) = temp
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = jx
if (noconj) then
if (nounit) temp = temp*ap(kk)
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + ap(k)*x(ix)
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + conjg(ap(k))*x(ix)
end do
end if
x(jx) = temp
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_ctpmv
pure module subroutine stdlib${ii}$_ztpmv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_dp
!! ZTPMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(dp), intent(in) :: ap(*)
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZTPMV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with cone pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x:= a*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = x(j)
k = kk
do i = 1,j - 1
x(i) = x(i) + temp*ap(k)
k = k + 1
end do
if (nounit) x(j) = x(j)*ap(kk+j-1)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
x(ix) = x(ix) + temp*ap(k)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*ap(kk+j-1)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
temp = x(j)
k = kk
do i = n,j + 1,-1
x(i) = x(i) + temp*ap(k)
k = k - 1
end do
if (nounit) x(j) = x(j)*ap(kk-n+j)
end if
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
x(ix) = x(ix) + temp*ap(k)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*ap(kk-n+j)
end if
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
else
! form x := a**t*x or x := a**h*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk - 1
if (noconj) then
if (nounit) temp = temp*ap(kk)
do i = j - 1,1,-1
temp = temp + ap(k)*x(i)
k = k - 1
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do i = j - 1,1,-1
temp = temp + conjg(ap(k))*x(i)
k = k - 1
end do
end if
x(j) = temp
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
temp = x(jx)
ix = jx
if (noconj) then
if (nounit) temp = temp*ap(kk)
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + ap(k)*x(ix)
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + conjg(ap(k))*x(ix)
end do
end if
x(jx) = temp
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk + 1
if (noconj) then
if (nounit) temp = temp*ap(kk)
do i = j + 1,n
temp = temp + ap(k)*x(i)
k = k + 1
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do i = j + 1,n
temp = temp + conjg(ap(k))*x(i)
k = k + 1
end do
end if
x(j) = temp
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = jx
if (noconj) then
if (nounit) temp = temp*ap(kk)
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + ap(k)*x(ix)
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + conjg(ap(k))*x(ix)
end do
end if
x(jx) = temp
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_ztpmv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tpmv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_${ck}$
!! ZTPMV: performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix, supplied in packed form.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(${ck}$), intent(in) :: ap(*)
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZTPMV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with cone pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x:= a*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
temp = x(j)
k = kk
do i = 1,j - 1
x(i) = x(i) + temp*ap(k)
k = k + 1
end do
if (nounit) x(j) = x(j)*ap(kk+j-1)
end if
kk = kk + j
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
x(ix) = x(ix) + temp*ap(k)
ix = ix + incx
end do
if (nounit) x(jx) = x(jx)*ap(kk+j-1)
end if
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
temp = x(j)
k = kk
do i = n,j + 1,-1
x(i) = x(i) + temp*ap(k)
k = k - 1
end do
if (nounit) x(j) = x(j)*ap(kk-n+j)
end if
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
if (x(jx)/=czero) then
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
x(ix) = x(ix) + temp*ap(k)
ix = ix - incx
end do
if (nounit) x(jx) = x(jx)*ap(kk-n+j)
end if
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
else
! form x := a**t*x or x := a**h*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk - 1
if (noconj) then
if (nounit) temp = temp*ap(kk)
do i = j - 1,1,-1
temp = temp + ap(k)*x(i)
k = k - 1
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do i = j - 1,1,-1
temp = temp + conjg(ap(k))*x(i)
k = k - 1
end do
end if
x(j) = temp
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
temp = x(jx)
ix = jx
if (noconj) then
if (nounit) temp = temp*ap(kk)
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + ap(k)*x(ix)
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
temp = temp + conjg(ap(k))*x(ix)
end do
end if
x(jx) = temp
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk + 1
if (noconj) then
if (nounit) temp = temp*ap(kk)
do i = j + 1,n
temp = temp + ap(k)*x(i)
k = k + 1
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do i = j + 1,n
temp = temp + conjg(ap(k))*x(i)
k = k + 1
end do
end if
x(j) = temp
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = jx
if (noconj) then
if (nounit) temp = temp*ap(kk)
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + ap(k)*x(ix)
end do
else
if (nounit) temp = temp*conjg(ap(kk))
do k = kk + 1,kk + n - j
ix = ix + incx
temp = temp + conjg(ap(k))*x(ix)
end do
end if
x(jx) = temp
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$tpmv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_strsv(uplo,trans,diag,n,a,lda,x,incx)
use stdlib_blas_constants_sp
!! STRSV solves one of the systems of equations
!! A*x = b, or A**T*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 matrix.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kx
logical(lk) :: nounit
! Intrinsic Functions
intrinsic :: max
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (ldak) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(1,j)
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/a(1,j)
x(jx) = temp
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_stbsv
pure module subroutine stdlib${ii}$_dtbsv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_dp
!! DTBSV solves one of the systems of equations
!! A*x = b, or A**T*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: nounit
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DTBSV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=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 (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
l = kplus1 - j
if (nounit) x(j) = x(j)/a(kplus1,j)
temp = x(j)
do i = j - 1,max(1,j-k),-1
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
kx = kx - incx
if (x(jx)/=zero) then
ix = kx
l = kplus1 - j
if (nounit) x(jx) = x(jx)/a(kplus1,j)
temp = x(jx)
do i = j - 1,max(1,j-k),-1
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix - incx
end do
end if
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
l = 1 - j
if (nounit) x(j) = x(j)/a(1,j)
temp = x(j)
do i = j + 1,min(n,j+k)
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
jx = kx
do j = 1,n
kx = kx + incx
if (x(jx)/=zero) then
ix = kx
l = 1 - j
if (nounit) x(jx) = x(jx)/a(1,j)
temp = x(jx)
do i = j + 1,min(n,j+k)
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
end if
else
! form x := inv( a**t)*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
temp = x(j)
l = kplus1 - j
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(kplus1,j)
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
l = kplus1 - j
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/a(kplus1,j)
x(jx) = temp
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(1,j)
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/a(1,j)
x(jx) = temp
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_dtbsv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tbsv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_${rk}$
!! DTBSV: solves one of the systems of equations
!! A*x = b, or A**T*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: nounit
! Intrinsic Functions
intrinsic :: max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DTBSV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=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 (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
l = kplus1 - j
if (nounit) x(j) = x(j)/a(kplus1,j)
temp = x(j)
do i = j - 1,max(1,j-k),-1
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
kx = kx - incx
if (x(jx)/=zero) then
ix = kx
l = kplus1 - j
if (nounit) x(jx) = x(jx)/a(kplus1,j)
temp = x(jx)
do i = j - 1,max(1,j-k),-1
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix - incx
end do
end if
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
l = 1 - j
if (nounit) x(j) = x(j)/a(1,j)
temp = x(j)
do i = j + 1,min(n,j+k)
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
jx = kx
do j = 1,n
kx = kx + incx
if (x(jx)/=zero) then
ix = kx
l = 1 - j
if (nounit) x(jx) = x(jx)/a(1,j)
temp = x(jx)
do i = j + 1,min(n,j+k)
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
end if
else
! form x := inv( a**t)*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
temp = x(j)
l = kplus1 - j
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(kplus1,j)
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
l = kplus1 - j
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/a(kplus1,j)
x(jx) = temp
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = 1 - j
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(1,j)
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
l = 1 - j
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/a(1,j)
x(jx) = temp
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$tbsv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctbsv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_sp
!! CTBSV solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CTBSV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of a are
! accessed by sequentially with cone pass through a.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
l = kplus1 - j
if (nounit) x(j) = x(j)/a(kplus1,j)
temp = x(j)
do i = j - 1,max(1,j-k),-1
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
kx = kx - incx
if (x(jx)/=czero) then
ix = kx
l = kplus1 - j
if (nounit) x(jx) = x(jx)/a(kplus1,j)
temp = x(jx)
do i = j - 1,max(1,j-k),-1
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix - incx
end do
end if
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
l = 1 - j
if (nounit) x(j) = x(j)/a(1,j)
temp = x(j)
do i = j + 1,min(n,j+k)
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
jx = kx
do j = 1,n
kx = kx + incx
if (x(jx)/=czero) then
ix = kx
l = 1 - j
if (nounit) x(jx) = x(jx)/a(1,j)
temp = x(jx)
do i = j + 1,min(n,j+k)
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
end if
else
! form x := inv( a**t )*x or x := inv( a**h )*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
temp = x(j)
l = kplus1 - j
if (noconj) then
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(kplus1,j)
else
do i = max(1,j-k),j - 1
temp = temp - conjg(a(l+i,j))*x(i)
end do
if (nounit) temp = temp/conjg(a(kplus1,j))
end if
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
l = kplus1 - j
if (noconj) then
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/a(kplus1,j)
else
do i = max(1,j-k),j - 1
temp = temp - conjg(a(l+i,j))*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/conjg(a(kplus1,j))
end if
x(jx) = temp
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = 1 - j
if (noconj) then
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(1,j)
else
do i = min(n,j+k),j + 1,-1
temp = temp - conjg(a(l+i,j))*x(i)
end do
if (nounit) temp = temp/conjg(a(1,j))
end if
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
l = 1 - j
if (noconj) then
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/a(1,j)
else
do i = min(n,j+k),j + 1,-1
temp = temp - conjg(a(l+i,j))*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/conjg(a(1,j))
end if
x(jx) = temp
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_ctbsv
pure module subroutine stdlib${ii}$_ztbsv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_dp
!! ZTBSV solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZTBSV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of a are
! accessed by sequentially with cone pass through a.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
l = kplus1 - j
if (nounit) x(j) = x(j)/a(kplus1,j)
temp = x(j)
do i = j - 1,max(1,j-k),-1
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
kx = kx - incx
if (x(jx)/=czero) then
ix = kx
l = kplus1 - j
if (nounit) x(jx) = x(jx)/a(kplus1,j)
temp = x(jx)
do i = j - 1,max(1,j-k),-1
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix - incx
end do
end if
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
l = 1 - j
if (nounit) x(j) = x(j)/a(1,j)
temp = x(j)
do i = j + 1,min(n,j+k)
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
jx = kx
do j = 1,n
kx = kx + incx
if (x(jx)/=czero) then
ix = kx
l = 1 - j
if (nounit) x(jx) = x(jx)/a(1,j)
temp = x(jx)
do i = j + 1,min(n,j+k)
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
end if
else
! form x := inv( a**t )*x or x := inv( a**h )*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
temp = x(j)
l = kplus1 - j
if (noconj) then
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(kplus1,j)
else
do i = max(1,j-k),j - 1
temp = temp - conjg(a(l+i,j))*x(i)
end do
if (nounit) temp = temp/conjg(a(kplus1,j))
end if
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
l = kplus1 - j
if (noconj) then
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/a(kplus1,j)
else
do i = max(1,j-k),j - 1
temp = temp - conjg(a(l+i,j))*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/conjg(a(kplus1,j))
end if
x(jx) = temp
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = 1 - j
if (noconj) then
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(1,j)
else
do i = min(n,j+k),j + 1,-1
temp = temp - conjg(a(l+i,j))*x(i)
end do
if (nounit) temp = temp/conjg(a(1,j))
end if
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
l = 1 - j
if (noconj) then
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/a(1,j)
else
do i = min(n,j+k),j + 1,-1
temp = temp - conjg(a(l+i,j))*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/conjg(a(1,j))
end if
x(jx) = temp
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_ztbsv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tbsv(uplo,trans,diag,n,k,a,lda,x,incx)
use stdlib_blas_constants_${ck}$
!! ZTBSV: solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, k, lda, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg,max,min
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (k<0) then
info = 5
else if (lda< (k+1)) then
info = 7
else if (incx==0) then
info = 9
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZTBSV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of a are
! accessed by sequentially with cone pass through a.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
l = kplus1 - j
if (nounit) x(j) = x(j)/a(kplus1,j)
temp = x(j)
do i = j - 1,max(1,j-k),-1
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
kx = kx - incx
if (x(jx)/=czero) then
ix = kx
l = kplus1 - j
if (nounit) x(jx) = x(jx)/a(kplus1,j)
temp = x(jx)
do i = j - 1,max(1,j-k),-1
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix - incx
end do
end if
jx = jx - incx
end do
end if
else
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
l = 1 - j
if (nounit) x(j) = x(j)/a(1,j)
temp = x(j)
do i = j + 1,min(n,j+k)
x(i) = x(i) - temp*a(l+i,j)
end do
end if
end do
else
jx = kx
do j = 1,n
kx = kx + incx
if (x(jx)/=czero) then
ix = kx
l = 1 - j
if (nounit) x(jx) = x(jx)/a(1,j)
temp = x(jx)
do i = j + 1,min(n,j+k)
x(ix) = x(ix) - temp*a(l+i,j)
ix = ix + incx
end do
end if
jx = jx + incx
end do
end if
end if
else
! form x := inv( a**t )*x or x := inv( a**h )*x.
if (stdlib_lsame(uplo,'U')) then
kplus1 = k + 1
if (incx==1) then
do j = 1,n
temp = x(j)
l = kplus1 - j
if (noconj) then
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(kplus1,j)
else
do i = max(1,j-k),j - 1
temp = temp - conjg(a(l+i,j))*x(i)
end do
if (nounit) temp = temp/conjg(a(kplus1,j))
end if
x(j) = temp
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
l = kplus1 - j
if (noconj) then
do i = max(1,j-k),j - 1
temp = temp - a(l+i,j)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/a(kplus1,j)
else
do i = max(1,j-k),j - 1
temp = temp - conjg(a(l+i,j))*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/conjg(a(kplus1,j))
end if
x(jx) = temp
jx = jx + incx
if (j>k) kx = kx + incx
end do
end if
else
if (incx==1) then
do j = n,1,-1
temp = x(j)
l = 1 - j
if (noconj) then
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(i)
end do
if (nounit) temp = temp/a(1,j)
else
do i = min(n,j+k),j + 1,-1
temp = temp - conjg(a(l+i,j))*x(i)
end do
if (nounit) temp = temp/conjg(a(1,j))
end if
x(j) = temp
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
l = 1 - j
if (noconj) then
do i = min(n,j+k),j + 1,-1
temp = temp - a(l+i,j)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/a(1,j)
else
do i = min(n,j+k),j + 1,-1
temp = temp - conjg(a(l+i,j))*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/conjg(a(1,j))
end if
x(jx) = temp
jx = jx - incx
if ((n-j)>=k) kx = kx - incx
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$tbsv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_stpsv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_sp
!! STPSV solves one of the systems of equations
!! A*x = b, or A**T*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 matrix, supplied in packed form.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(sp), intent(in) :: ap(*)
real(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: nounit
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('STPSV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with one pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk - 1
do i = j - 1,1,-1
x(i) = x(i) - temp*ap(k)
k = k - 1
end do
end if
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
if (x(jx)/=zero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk + 1
do i = j + 1,n
x(i) = x(i) - temp*ap(k)
k = k + 1
end do
end if
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
else
! form x := inv( a**t )*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk
do i = 1,j - 1
temp = temp - ap(k)*x(i)
k = k + 1
end do
if (nounit) temp = temp/ap(kk+j-1)
x(j) = temp
kk = kk + j
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
temp = temp - ap(k)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/ap(kk+j-1)
x(jx) = temp
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk
do i = n,j + 1,-1
temp = temp - ap(k)*x(i)
k = k - 1
end do
if (nounit) temp = temp/ap(kk-n+j)
x(j) = temp
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
temp = temp - ap(k)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/ap(kk-n+j)
x(jx) = temp
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_stpsv
pure module subroutine stdlib${ii}$_dtpsv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_dp
!! DTPSV solves one of the systems of equations
!! A*x = b, or A**T*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 matrix, supplied in packed form.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(dp), intent(in) :: ap(*)
real(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: nounit
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DTPSV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with one pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk - 1
do i = j - 1,1,-1
x(i) = x(i) - temp*ap(k)
k = k - 1
end do
end if
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
if (x(jx)/=zero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk + 1
do i = j + 1,n
x(i) = x(i) - temp*ap(k)
k = k + 1
end do
end if
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
else
! form x := inv( a**t )*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk
do i = 1,j - 1
temp = temp - ap(k)*x(i)
k = k + 1
end do
if (nounit) temp = temp/ap(kk+j-1)
x(j) = temp
kk = kk + j
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
temp = temp - ap(k)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/ap(kk+j-1)
x(jx) = temp
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk
do i = n,j + 1,-1
temp = temp - ap(k)*x(i)
k = k - 1
end do
if (nounit) temp = temp/ap(kk-n+j)
x(j) = temp
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
temp = temp - ap(k)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/ap(kk-n+j)
x(jx) = temp
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_dtpsv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$tpsv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_${rk}$
!! DTPSV: solves one of the systems of equations
!! A*x = b, or A**T*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 matrix, supplied in packed form.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
real(${rk}$), intent(in) :: ap(*)
real(${rk}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: nounit
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('DTPSV ',info)
return
end if
! quick return if possible.
if (n==0) return
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with one pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=zero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk - 1
do i = j - 1,1,-1
x(i) = x(i) - temp*ap(k)
k = k - 1
end do
end if
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
if (x(jx)/=zero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=zero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk + 1
do i = j + 1,n
x(i) = x(i) - temp*ap(k)
k = k + 1
end do
end if
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
if (x(jx)/=zero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
else
! form x := inv( a**t )*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk
do i = 1,j - 1
temp = temp - ap(k)*x(i)
k = k + 1
end do
if (nounit) temp = temp/ap(kk+j-1)
x(j) = temp
kk = kk + j
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
do k = kk,kk + j - 2
temp = temp - ap(k)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/ap(kk+j-1)
x(jx) = temp
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk
do i = n,j + 1,-1
temp = temp - ap(k)*x(i)
k = k - 1
end do
if (nounit) temp = temp/ap(kk-n+j)
x(j) = temp
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
do k = kk,kk - (n- (j+1)),-1
temp = temp - ap(k)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/ap(kk-n+j)
x(jx) = temp
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$tpsv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ctpsv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_sp
!! CTPSV solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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 matrix, supplied in packed form.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(sp), intent(in) :: ap(*)
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(sp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('CTPSV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with cone pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk - 1
do i = j - 1,1,-1
x(i) = x(i) - temp*ap(k)
k = k - 1
end do
end if
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
if (x(jx)/=czero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk + 1
do i = j + 1,n
x(i) = x(i) - temp*ap(k)
k = k + 1
end do
end if
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
else
! form x := inv( a**t )*x or x := inv( a**h )*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk
if (noconj) then
do i = 1,j - 1
temp = temp - ap(k)*x(i)
k = k + 1
end do
if (nounit) temp = temp/ap(kk+j-1)
else
do i = 1,j - 1
temp = temp - conjg(ap(k))*x(i)
k = k + 1
end do
if (nounit) temp = temp/conjg(ap(kk+j-1))
end if
x(j) = temp
kk = kk + j
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
if (noconj) then
do k = kk,kk + j - 2
temp = temp - ap(k)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/ap(kk+j-1)
else
do k = kk,kk + j - 2
temp = temp - conjg(ap(k))*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/conjg(ap(kk+j-1))
end if
x(jx) = temp
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk
if (noconj) then
do i = n,j + 1,-1
temp = temp - ap(k)*x(i)
k = k - 1
end do
if (nounit) temp = temp/ap(kk-n+j)
else
do i = n,j + 1,-1
temp = temp - conjg(ap(k))*x(i)
k = k - 1
end do
if (nounit) temp = temp/conjg(ap(kk-n+j))
end if
x(j) = temp
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
if (noconj) then
do k = kk,kk - (n- (j+1)),-1
temp = temp - ap(k)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/ap(kk-n+j)
else
do k = kk,kk - (n- (j+1)),-1
temp = temp - conjg(ap(k))*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/conjg(ap(kk-n+j))
end if
x(jx) = temp
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_ctpsv
pure module subroutine stdlib${ii}$_ztpsv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_dp
!! ZTPSV solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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 matrix, supplied in packed form.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(dp), intent(in) :: ap(*)
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(dp) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZTPSV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with cone pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk - 1
do i = j - 1,1,-1
x(i) = x(i) - temp*ap(k)
k = k - 1
end do
end if
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
if (x(jx)/=czero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk + 1
do i = j + 1,n
x(i) = x(i) - temp*ap(k)
k = k + 1
end do
end if
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
else
! form x := inv( a**t )*x or x := inv( a**h )*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk
if (noconj) then
do i = 1,j - 1
temp = temp - ap(k)*x(i)
k = k + 1
end do
if (nounit) temp = temp/ap(kk+j-1)
else
do i = 1,j - 1
temp = temp - conjg(ap(k))*x(i)
k = k + 1
end do
if (nounit) temp = temp/conjg(ap(kk+j-1))
end if
x(j) = temp
kk = kk + j
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
if (noconj) then
do k = kk,kk + j - 2
temp = temp - ap(k)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/ap(kk+j-1)
else
do k = kk,kk + j - 2
temp = temp - conjg(ap(k))*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/conjg(ap(kk+j-1))
end if
x(jx) = temp
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk
if (noconj) then
do i = n,j + 1,-1
temp = temp - ap(k)*x(i)
k = k - 1
end do
if (nounit) temp = temp/ap(kk-n+j)
else
do i = n,j + 1,-1
temp = temp - conjg(ap(k))*x(i)
k = k - 1
end do
if (nounit) temp = temp/conjg(ap(kk-n+j))
end if
x(j) = temp
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
if (noconj) then
do k = kk,kk - (n- (j+1)),-1
temp = temp - ap(k)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/ap(kk-n+j)
else
do k = kk,kk - (n- (j+1)),-1
temp = temp - conjg(ap(k))*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/conjg(ap(kk-n+j))
end if
x(jx) = temp
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_ztpsv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$tpsv(uplo,trans,diag,n,ap,x,incx)
use stdlib_blas_constants_${ck}$
!! ZTPSV: solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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 matrix, supplied in packed form.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
! -- reference blas level2 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
character, intent(in) :: diag, trans, uplo
! Array Arguments
complex(${ck}$), intent(in) :: ap(*)
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: temp
integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx
logical(lk) :: noconj, nounit
! Intrinsic Functions
intrinsic :: conjg
! test the input parameters.
info = 0
if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then
info = 1
else if (.not.stdlib_lsame(trans,'N') .and. .not.stdlib_lsame(trans,'T') &
.and..not.stdlib_lsame(trans,'C')) then
info = 2
else if (.not.stdlib_lsame(diag,'U') .and. .not.stdlib_lsame(diag,'N')) then
info = 3
else if (n<0) then
info = 4
else if (incx==0) then
info = 7
end if
if (info/=0) then
call stdlib${ii}$_xerbla('ZTPSV ',info)
return
end if
! quick return if possible.
if (n==0) return
noconj = stdlib_lsame(trans,'T')
nounit = stdlib_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<=0) then
kx = 1 - (n-1)*incx
else if (incx/=1) then
kx = 1
end if
! start the operations. in this version the elements of ap are
! accessed sequentially with cone pass through ap.
if (stdlib_lsame(trans,'N')) then
! form x := inv( a )*x.
if (stdlib_lsame(uplo,'U')) then
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
if (x(j)/=czero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk - 1
do i = j - 1,1,-1
x(i) = x(i) - temp*ap(k)
k = k - 1
end do
end if
kk = kk - j
end do
else
jx = kx + (n-1)*incx
do j = n,1,-1
if (x(jx)/=czero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk - 1,kk - j + 1,-1
ix = ix - incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx - incx
kk = kk - j
end do
end if
else
kk = 1
if (incx==1) then
do j = 1,n
if (x(j)/=czero) then
if (nounit) x(j) = x(j)/ap(kk)
temp = x(j)
k = kk + 1
do i = j + 1,n
x(i) = x(i) - temp*ap(k)
k = k + 1
end do
end if
kk = kk + (n-j+1)
end do
else
jx = kx
do j = 1,n
if (x(jx)/=czero) then
if (nounit) x(jx) = x(jx)/ap(kk)
temp = x(jx)
ix = jx
do k = kk + 1,kk + n - j
ix = ix + incx
x(ix) = x(ix) - temp*ap(k)
end do
end if
jx = jx + incx
kk = kk + (n-j+1)
end do
end if
end if
else
! form x := inv( a**t )*x or x := inv( a**h )*x.
if (stdlib_lsame(uplo,'U')) then
kk = 1
if (incx==1) then
do j = 1,n
temp = x(j)
k = kk
if (noconj) then
do i = 1,j - 1
temp = temp - ap(k)*x(i)
k = k + 1
end do
if (nounit) temp = temp/ap(kk+j-1)
else
do i = 1,j - 1
temp = temp - conjg(ap(k))*x(i)
k = k + 1
end do
if (nounit) temp = temp/conjg(ap(kk+j-1))
end if
x(j) = temp
kk = kk + j
end do
else
jx = kx
do j = 1,n
temp = x(jx)
ix = kx
if (noconj) then
do k = kk,kk + j - 2
temp = temp - ap(k)*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/ap(kk+j-1)
else
do k = kk,kk + j - 2
temp = temp - conjg(ap(k))*x(ix)
ix = ix + incx
end do
if (nounit) temp = temp/conjg(ap(kk+j-1))
end if
x(jx) = temp
jx = jx + incx
kk = kk + j
end do
end if
else
kk = (n* (n+1))/2
if (incx==1) then
do j = n,1,-1
temp = x(j)
k = kk
if (noconj) then
do i = n,j + 1,-1
temp = temp - ap(k)*x(i)
k = k - 1
end do
if (nounit) temp = temp/ap(kk-n+j)
else
do i = n,j + 1,-1
temp = temp - conjg(ap(k))*x(i)
k = k - 1
end do
if (nounit) temp = temp/conjg(ap(kk-n+j))
end if
x(j) = temp
kk = kk - (n-j+1)
end do
else
kx = kx + (n-1)*incx
jx = kx
do j = n,1,-1
temp = x(jx)
ix = kx
if (noconj) then
do k = kk,kk - (n- (j+1)),-1
temp = temp - ap(k)*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/ap(kk-n+j)
else
do k = kk,kk - (n- (j+1)),-1
temp = temp - conjg(ap(k))*x(ix)
ix = ix - incx
end do
if (nounit) temp = temp/conjg(ap(kk-n+j))
end if
x(jx) = temp
jx = jx - incx
kk = kk - (n-j+1)
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$tpsv
#:endif
#:endfor
#:endfor
end submodule stdlib_blas_level2_tri
fortran-lang-stdlib-0ede301/src/blas/stdlib_blas_level3_tri.fypp 0000664 0001750 0001750 00000352260 15135654166 025220 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_blas) stdlib_blas_level3_tri
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_strmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
use stdlib_blas_constants_sp
!! STRMM 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**T.
! -- reference blas level3 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha
integer(${ik}$), intent(in) :: lda, ldb, m, n
character, intent(in) :: diag, side, transa, uplo
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: b(ldb,*)
! =====================================================================
! Intrinsic Functions
intrinsic :: max
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, j, k, nrowa
logical(lk) :: lside, nounit, upper
! test the input parameters.
lside = stdlib_lsame(side,'L')
if (lside) then
nrowa = m
else
nrowa = n
end if
nounit = stdlib_lsame(diag,'N')
upper = stdlib_lsame(uplo,'U')
info = 0
if ((.not.lside) .and. (.not.stdlib_lsame(side,'R'))) then
info = 1
else if ((.not.upper) .and. (.not.stdlib_lsame(uplo,'L'))) then
info = 2
else if ((.not.stdlib_lsame(transa,'N')) .and.(.not.stdlib_lsame(transa,'T')) .and.(&
.not.stdlib_lsame(transa,'C'))) then
info = 3
else if ((.not.stdlib_lsame(diag,'U')) .and. (.not.stdlib_lsame(diag,'N'))) &
then
info = 4
else if (m<0) then
info = 5
else if (n<0) then
info = 6
else if (lda= 0, else LX = 1+(1-N)*INCX, and LY is
!! defined in a similar way using INCY.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
real(sp), intent(in) :: sx(*), sy(*)
! authors:
! ========
! lawson, c. l., (jpl), hanson, r. j., (snla),
! kincaid, d. r., (u. of texas), krogh, f. t., (jpl)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, kx, ky, ns
! Intrinsic Functions
intrinsic :: real
stdlib${ii}$_dsdot = zero
if (n<=0) return
if (incx==incy .and. incx>0) then
! code for equal, positive, non-unit increments.
ns = n*incx
do i = 1,ns,incx
stdlib${ii}$_dsdot = stdlib${ii}$_dsdot + real(sx(i),KIND=dp)*real(sy(i),KIND=dp)
end do
else
! code for unequal or nonpositive increments.
kx = 1
ky = 1
if (incx<0) kx = 1 + (1-n)*incx
if (incy<0) ky = 1 + (1-n)*incy
do i = 1,n
stdlib${ii}$_dsdot = stdlib${ii}$_dsdot + real(sx(kx),KIND=dp)*real(sy(ky),KIND=dp)
kx = kx + incx
ky = ky + incy
end do
end if
return
end function stdlib${ii}$_dsdot
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure real(${rk}$) module function stdlib${ii}$_${ri}$sdot(n,sx,incx,sy,incy)
use stdlib_blas_constants_${rk}$
!! Compute the inner product of two vectors with extended
!! precision accumulation and result.
!! Returns D.P. dot product accumulated in D.P., for S.P. SX and SY
!! DSDOT: = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY),
!! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is
!! defined in a similar way using INCY.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
real(dp), intent(in) :: sx(*), sy(*)
! authors:
! ========
! lawson, c. l., (jpl), hanson, r. j., (snla),
! kincaid, d. r., (u. of texas), krogh, f. t., (jpl)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, kx, ky, ns
! Intrinsic Functions
intrinsic :: real
stdlib${ii}$_${ri}$sdot = zero
if (n<=0) return
if (incx==incy .and. incx>0) then
! code for equal, positive, non-unit increments.
ns = n*incx
do i = 1,ns,incx
stdlib${ii}$_${ri}$sdot = stdlib${ii}$_${ri}$sdot + real(sx(i),KIND=${rk}$)*real(sy(i),KIND=${rk}$)
end do
else
! code for unequal or nonpositive increments.
kx = 1
ky = 1
if (incx<0) kx = 1 + (1-n)*incx
if (incy<0) ky = 1 + (1-n)*incy
do i = 1,n
stdlib${ii}$_${ri}$sdot = stdlib${ii}$_${ri}$sdot + real(sx(kx),KIND=${rk}$)*real(sy(ky),KIND=${rk}$)
kx = kx + incx
ky = ky + incy
end do
end if
return
end function stdlib${ii}$_${ri}$sdot
#:endif
#:endfor
pure complex(sp) module function stdlib${ii}$_cdotc(n,cx,incx,cy,incy)
use stdlib_blas_constants_sp
!! CDOTC forms the dot product of two complex vectors
!! CDOTC = X^H * Y
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
complex(sp), intent(in) :: cx(*), cy(*)
! =====================================================================
! Local Scalars
complex(sp) :: ctemp
integer(${ik}$) :: i, ix, iy
! Intrinsic Functions
intrinsic :: conjg
ctemp = (0.0_sp,0.0_sp)
stdlib${ii}$_cdotc = (0.0_sp,0.0_sp)
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
ctemp = ctemp + conjg(cx(i))*cy(i)
end do
else
! code for unequal increments or equal increments
! not equal to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do i = 1,n
ctemp = ctemp + conjg(cx(ix))*cy(iy)
ix = ix + incx
iy = iy + incy
end do
end if
stdlib${ii}$_cdotc = ctemp
return
end function stdlib${ii}$_cdotc
pure complex(dp) module function stdlib${ii}$_zdotc(n,zx,incx,zy,incy)
use stdlib_blas_constants_dp
!! ZDOTC forms the dot product of two complex vectors
!! ZDOTC = X^H * Y
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
complex(dp), intent(in) :: zx(*), zy(*)
! =====================================================================
! Local Scalars
complex(dp) :: ztemp
integer(${ik}$) :: i, ix, iy
! Intrinsic Functions
intrinsic :: conjg
ztemp = (0.0_dp,0.0_dp)
stdlib${ii}$_zdotc = (0.0_dp,0.0_dp)
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
ztemp = ztemp + conjg(zx(i))*zy(i)
end do
else
! code for unequal increments or equal increments
! not equal to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do i = 1,n
ztemp = ztemp + conjg(zx(ix))*zy(iy)
ix = ix + incx
iy = iy + incy
end do
end if
stdlib${ii}$_zdotc = ztemp
return
end function stdlib${ii}$_zdotc
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure complex(${ck}$) module function stdlib${ii}$_${ci}$dotc(n,zx,incx,zy,incy)
use stdlib_blas_constants_${ck}$
!! ZDOTC: forms the dot product of two complex vectors
!! ZDOTC = X^H * Y
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
complex(${ck}$), intent(in) :: zx(*), zy(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: ztemp
integer(${ik}$) :: i, ix, iy
! Intrinsic Functions
intrinsic :: conjg
ztemp = (0.0_${ck}$,0.0_${ck}$)
stdlib${ii}$_${ci}$dotc = (0.0_${ck}$,0.0_${ck}$)
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
ztemp = ztemp + conjg(zx(i))*zy(i)
end do
else
! code for unequal increments or equal increments
! not equal to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do i = 1,n
ztemp = ztemp + conjg(zx(ix))*zy(iy)
ix = ix + incx
iy = iy + incy
end do
end if
stdlib${ii}$_${ci}$dotc = ztemp
return
end function stdlib${ii}$_${ci}$dotc
#:endif
#:endfor
pure complex(sp) module function stdlib${ii}$_cdotu(n,cx,incx,cy,incy)
use stdlib_blas_constants_sp
!! CDOTU forms the dot product of two complex vectors
!! CDOTU = X^T * Y
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
complex(sp), intent(in) :: cx(*), cy(*)
! =====================================================================
! Local Scalars
complex(sp) :: ctemp
integer(${ik}$) :: i, ix, iy
ctemp = (0.0_sp,0.0_sp)
stdlib${ii}$_cdotu = (0.0_sp,0.0_sp)
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
ctemp = ctemp + cx(i)*cy(i)
end do
else
! code for unequal increments or equal increments
! not equal to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do i = 1,n
ctemp = ctemp + cx(ix)*cy(iy)
ix = ix + incx
iy = iy + incy
end do
end if
stdlib${ii}$_cdotu = ctemp
return
end function stdlib${ii}$_cdotu
pure complex(dp) module function stdlib${ii}$_zdotu(n,zx,incx,zy,incy)
use stdlib_blas_constants_dp
!! ZDOTU forms the dot product of two complex vectors
!! ZDOTU = X^T * Y
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
complex(dp), intent(in) :: zx(*), zy(*)
! =====================================================================
! Local Scalars
complex(dp) :: ztemp
integer(${ik}$) :: i, ix, iy
ztemp = (0.0_dp,0.0_dp)
stdlib${ii}$_zdotu = (0.0_dp,0.0_dp)
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
ztemp = ztemp + zx(i)*zy(i)
end do
else
! code for unequal increments or equal increments
! not equal to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do i = 1,n
ztemp = ztemp + zx(ix)*zy(iy)
ix = ix + incx
iy = iy + incy
end do
end if
stdlib${ii}$_zdotu = ztemp
return
end function stdlib${ii}$_zdotu
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure complex(${ck}$) module function stdlib${ii}$_${ci}$dotu(n,zx,incx,zy,incy)
use stdlib_blas_constants_${ck}$
!! ZDOTU: forms the dot product of two complex vectors
!! ZDOTU = X^T * Y
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
complex(${ck}$), intent(in) :: zx(*), zy(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: ztemp
integer(${ik}$) :: i, ix, iy
ztemp = (0.0_${ck}$,0.0_${ck}$)
stdlib${ii}$_${ci}$dotu = (0.0_${ck}$,0.0_${ck}$)
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
ztemp = ztemp + zx(i)*zy(i)
end do
else
! code for unequal increments or equal increments
! not equal to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do i = 1,n
ztemp = ztemp + zx(ix)*zy(iy)
ix = ix + incx
iy = iy + incy
end do
end if
stdlib${ii}$_${ci}$dotu = ztemp
return
end function stdlib${ii}$_${ci}$dotu
#:endif
#:endfor
pure real(sp) module function stdlib${ii}$_snrm2( n, x, incx )
use stdlib_blas_constants_sp
!! SNRM2 returns the euclidean norm of a vector via the function
!! name, so that
!! SNRM2 := sqrt( x'*x ).
! -- reference blas level1 routine (version 3.9.1_sp) --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! march 2021
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
! Array Arguments
real(sp), intent(in) :: x(*)
! =====================================================================
! Constants
real(sp), parameter :: maxn = huge(0.0_sp)
! .. blue's scaling constants ..
! Local Scalars
integer(${ik}$) :: i, ix
logical(lk) :: notbig
real(sp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
! quick return if possible
stdlib${ii}$_snrm2 = zero
if( n <= 0 ) return
scl = one
sumsq = zero
! compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! the thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(x(ix))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
! combine abig and amed or amed and asml if more than one
! accumulator was used.
if (abig > zero) then
! combine abig and amed if abig > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
! combine amed and asml if asml > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
! otherwise all values are mid-range
scl = one
sumsq = amed
end if
stdlib${ii}$_snrm2 = scl*sqrt( sumsq )
return
end function stdlib${ii}$_snrm2
pure real(dp) module function stdlib${ii}$_dnrm2( n, x, incx )
use stdlib_blas_constants_dp
!! DNRM2 returns the euclidean norm of a vector via the function
!! name, so that
!! DNRM2 := sqrt( x'*x )
! -- reference blas level1 routine (version 3.9.1_dp) --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! march 2021
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
! Array Arguments
real(dp), intent(in) :: x(*)
! =====================================================================
! Constants
real(dp), parameter :: maxn = huge(0.0_dp)
! .. blue's scaling constants ..
! Local Scalars
integer(${ik}$) :: i, ix
logical(lk) :: notbig
real(dp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
! quick return if possible
stdlib${ii}$_dnrm2 = zero
if( n <= 0 ) return
scl = one
sumsq = zero
! compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! the thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(x(ix))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
! combine abig and amed or amed and asml if more than one
! accumulator was used.
if (abig > zero) then
! combine abig and amed if abig > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
! combine amed and asml if asml > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
! otherwise all values are mid-range
scl = one
sumsq = amed
end if
stdlib${ii}$_dnrm2 = scl*sqrt( sumsq )
return
end function stdlib${ii}$_dnrm2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure real(${rk}$) module function stdlib${ii}$_${ri}$nrm2( n, x, incx )
use stdlib_blas_constants_${rk}$
!! DNRM2: returns the euclidean norm of a vector via the function
!! name, so that
!! DNRM2 := sqrt( x'*x )
! -- reference blas level1 routine (version 3.9.1_${rk}$) --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! march 2021
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
! Array Arguments
real(${rk}$), intent(in) :: x(*)
! =====================================================================
! Constants
real(${rk}$), parameter :: maxn = huge(0.0_${rk}$)
! .. blue's scaling constants ..
! Local Scalars
integer(${ik}$) :: i, ix
logical(lk) :: notbig
real(${rk}$) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
! quick return if possible
stdlib${ii}$_${ri}$nrm2 = zero
if( n <= 0 ) return
scl = one
sumsq = zero
! compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! the thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(x(ix))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
! combine abig and amed or amed and asml if more than one
! accumulator was used.
if (abig > zero) then
! combine abig and amed if abig > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
! combine amed and asml if asml > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
! otherwise all values are mid-range
scl = one
sumsq = amed
end if
stdlib${ii}$_${ri}$nrm2 = scl*sqrt( sumsq )
return
end function stdlib${ii}$_${ri}$nrm2
#:endif
#:endfor
pure real(sp) module function stdlib${ii}$_scnrm2( n, x, incx )
use stdlib_blas_constants_sp
!! SCNRM2 returns the euclidean norm of a vector via the function
!! name, so that
!! SCNRM2 := sqrt( x**H*x )
! -- reference blas level1 routine (version 3.9.1_sp) --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! march 2021
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
! Array Arguments
complex(sp), intent(in) :: x(*)
! =====================================================================
! Constants
real(sp), parameter :: maxn = huge(0.0_sp)
! .. blue's scaling constants ..
! Local Scalars
integer(${ik}$) :: i, ix
logical(lk) :: notbig
real(sp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
! quick return if possible
stdlib${ii}$_scnrm2 = zero
if( n <= 0 ) return
scl = one
sumsq = zero
! compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! the thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(real(x(ix),KIND=sp))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ax = abs(aimag(x(ix)))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
! combine abig and amed or amed and asml if more than one
! accumulator was used.
if (abig > zero) then
! combine abig and amed if abig > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
! combine amed and asml if asml > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
! otherwise all values are mid-range
scl = one
sumsq = amed
end if
stdlib${ii}$_scnrm2 = scl*sqrt( sumsq )
return
end function stdlib${ii}$_scnrm2
pure real(dp) module function stdlib${ii}$_dznrm2( n, x, incx )
use stdlib_blas_constants_dp
!! DZNRM2 returns the euclidean norm of a vector via the function
!! name, so that
!! DZNRM2 := sqrt( x**H*x )
! -- reference blas level1 routine (version 3.9.1_dp) --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! march 2021
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
! Array Arguments
complex(dp), intent(in) :: x(*)
! =====================================================================
! Constants
real(dp), parameter :: maxn = huge(0.0_dp)
! .. blue's scaling constants ..
! Local Scalars
integer(${ik}$) :: i, ix
logical(lk) :: notbig
real(dp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
! quick return if possible
stdlib${ii}$_dznrm2 = zero
if( n <= 0 ) return
scl = one
sumsq = zero
! compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! the thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(real(x(ix),KIND=dp))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ax = abs(aimag(x(ix)))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
! combine abig and amed or amed and asml if more than one
! accumulator was used.
if (abig > zero) then
! combine abig and amed if abig > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
! combine amed and asml if asml > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
! otherwise all values are mid-range
scl = one
sumsq = amed
end if
stdlib${ii}$_dznrm2 = scl*sqrt( sumsq )
return
end function stdlib${ii}$_dznrm2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure real(${rk}$) module function stdlib${ii}$_${ri}$znrm2( n, x, incx )
use stdlib_blas_constants_${rk}$
!! DZNRM2: returns the euclidean norm of a vector via the function
!! name, so that
!! DZNRM2 := sqrt( x**H*x )
! -- reference blas level1 routine (version 3.9.1_${rk}$) --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! march 2021
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, n
! Array Arguments
complex(${rk}$), intent(in) :: x(*)
! =====================================================================
! Constants
real(${rk}$), parameter :: maxn = huge(0.0_${rk}$)
! .. blue's scaling constants ..
! Local Scalars
integer(${ik}$) :: i, ix
logical(lk) :: notbig
real(${rk}$) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
! quick return if possible
stdlib${ii}$_${ri}$znrm2 = zero
if( n <= 0 ) return
scl = one
sumsq = zero
! compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! the thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(real(x(ix),KIND=${rk}$))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ax = abs(aimag(x(ix)))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
! combine abig and amed or amed and asml if more than one
! accumulator was used.
if (abig > zero) then
! combine abig and amed if abig > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
! combine amed and asml if asml > 0.
if ( (amed > zero) .or. (amed > maxn) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
! otherwise all values are mid-range
scl = one
sumsq = amed
end if
stdlib${ii}$_${ri}$znrm2 = scl*sqrt( sumsq )
return
end function stdlib${ii}$_${ri}$znrm2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_srot(n,sx,incx,sy,incy,c,s)
use stdlib_blas_constants_sp
!! applies a plane rotation.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: c, s
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
real(sp), intent(inout) :: sx(*), sy(*)
! =====================================================================
! Local Scalars
real(sp) :: stemp
integer(${ik}$) :: i, ix, iy
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
stemp = c*sx(i) + s*sy(i)
sy(i) = c*sy(i) - s*sx(i)
sx(i) = stemp
end do
else
! code for unequal increments or equal increments not equal
! to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do i = 1,n
stemp = c*sx(ix) + s*sy(iy)
sy(iy) = c*sy(iy) - s*sx(ix)
sx(ix) = stemp
ix = ix + incx
iy = iy + incy
end do
end if
return
end subroutine stdlib${ii}$_srot
pure module subroutine stdlib${ii}$_drot(n,dx,incx,dy,incy,c,s)
use stdlib_blas_constants_dp
!! DROT applies a plane rotation.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(dp), intent(in) :: c, s
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
real(dp), intent(inout) :: dx(*), dy(*)
! =====================================================================
! Local Scalars
real(dp) :: dtemp
integer(${ik}$) :: i, ix, iy
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
dtemp = c*dx(i) + s*dy(i)
dy(i) = c*dy(i) - s*dx(i)
dx(i) = dtemp
end do
else
! code for unequal increments or equal increments not equal
! to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do 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
end do
end if
return
end subroutine stdlib${ii}$_drot
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$rot(n,dx,incx,dy,incy,c,s)
use stdlib_blas_constants_${rk}$
!! DROT: applies a plane rotation.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(${rk}$), intent(in) :: c, s
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
real(${rk}$), intent(inout) :: dx(*), dy(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: dtemp
integer(${ik}$) :: i, ix, iy
if (n<=0) return
if (incx==1 .and. incy==1) then
! code for both increments equal to 1
do i = 1,n
dtemp = c*dx(i) + s*dy(i)
dy(i) = c*dy(i) - s*dx(i)
dx(i) = dtemp
end do
else
! code for unequal increments or equal increments not equal
! to 1
ix = 1
iy = 1
if (incx<0) ix = (-n+1)*incx + 1
if (incy<0) iy = (-n+1)*incy + 1
do 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
end do
end if
return
end subroutine stdlib${ii}$_${ri}$rot
#:endif
#:endfor
pure module subroutine stdlib${ii}$_zdrot( n, zx, incx, zy, incy, c, s )
use stdlib_blas_constants_dp
!! Applies a plane rotation, where the cos and sin (c and s) are real
!! and the vectors cx and cy are complex.
!! jack dongarra, linpack, 3/11/78.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
real(dp), intent(in) :: c, s
! Array Arguments
complex(dp), intent(inout) :: zx(*), zy(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ix, iy
complex(dp) :: ctemp
! Executable Statements
if( n<=0 )return
if( incx==1 .and. incy==1 ) then
! code for both increments equal to 1
do i = 1, n
ctemp = c*zx( i ) + s*zy( i )
zy( i ) = c*zy( i ) - s*zx( i )
zx( i ) = ctemp
end do
else
! code for unequal increments or equal increments not equal
! to 1
ix = 1
iy = 1
if( incx<0 )ix = ( -n+1 )*incx + 1
if( incy<0 )iy = ( -n+1 )*incy + 1
do i = 1, n
ctemp = c*zx( ix ) + s*zy( iy )
zy( iy ) = c*zy( iy ) - s*zx( ix )
zx( ix ) = ctemp
ix = ix + incx
iy = iy + incy
end do
end if
return
end subroutine stdlib${ii}$_zdrot
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$drot( n, zx, incx, zy, incy, c, s )
use stdlib_blas_constants_${ck}$
!! Applies a plane rotation, where the cos and sin (c and s) are real
!! and the vectors cx and cy are complex.
!! jack dongarra, linpack, 3/11/78.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
real(${ck}$), intent(in) :: c, s
! Array Arguments
complex(${ck}$), intent(inout) :: zx(*), zy(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ix, iy
complex(${ck}$) :: ctemp
! Executable Statements
if( n<=0 )return
if( incx==1 .and. incy==1 ) then
! code for both increments equal to 1
do i = 1, n
ctemp = c*zx( i ) + s*zy( i )
zy( i ) = c*zy( i ) - s*zx( i )
zx( i ) = ctemp
end do
else
! code for unequal increments or equal increments not equal
! to 1
ix = 1
iy = 1
if( incx<0 )ix = ( -n+1 )*incx + 1
if( incy<0 )iy = ( -n+1 )*incy + 1
do i = 1, n
ctemp = c*zx( ix ) + s*zy( iy )
zy( iy ) = c*zy( iy ) - s*zx( ix )
zx( ix ) = ctemp
ix = ix + incx
iy = iy + incy
end do
end if
return
end subroutine stdlib${ii}$_${ci}$drot
#:endif
#:endfor
pure module subroutine stdlib${ii}$_srotg( a, b, c, s )
use stdlib_blas_constants_sp
!! The computation uses the formulas
!! sigma = sgn(a) if |a| > |b|
!! = sgn(b) if |b| >= |a|
!! r = sigma*sqrt( a**2 + b**2 )
!! c = 1; s = 0 if r = 0
!! c = a/r; s = b/r if r != 0
!! The subroutine also computes
!! z = s if |a| > |b|,
!! = 1/c if |b| >= |a| and c != 0
!! = 1 if c = 0
!! This allows c and s to be reconstructed from z as follows:
!! If z = 1, set c = 0, s = 1.
!! If |z| < 1, set c = sqrt(1 - z**2) and s = z.
!! If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2).
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Constants
! Scaling Constants
! Scalar Arguments
real(sp), intent(inout) :: a, b
real(sp), intent(out) :: c, s
! =====================================================================
! Local Scalars
real(sp) :: anorm, bnorm, scl, sigma, r, z
anorm = abs(a)
bnorm = abs(b)
if( bnorm == zero ) then
c = one
s = zero
b = zero
else if( anorm == zero ) then
c = zero
s = one
a = b
b = one
else
scl = min( safmax, max( safmin, anorm, bnorm ) )
if( anorm > bnorm ) then
sigma = sign(one,a)
else
sigma = sign(one,b)
end if
r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) )
c = a/r
s = b/r
if( anorm > bnorm ) then
z = s
else if( c /= zero ) then
z = one/c
else
z = one
end if
a = r
b = z
end if
return
end subroutine stdlib${ii}$_srotg
pure module subroutine stdlib${ii}$_drotg( a, b, c, s )
use stdlib_blas_constants_dp
!! The computation uses the formulas
!! sigma = sgn(a) if |a| > |b|
!! = sgn(b) if |b| >= |a|
!! r = sigma*sqrt( a**2 + b**2 )
!! c = 1; s = 0 if r = 0
!! c = a/r; s = b/r if r != 0
!! The subroutine also computes
!! z = s if |a| > |b|,
!! = 1/c if |b| >= |a| and c != 0
!! = 1 if c = 0
!! This allows c and s to be reconstructed from z as follows:
!! If z = 1, set c = 0, s = 1.
!! If |z| < 1, set c = sqrt(1 - z**2) and s = z.
!! If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2).
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scaling Constants
! Scalar Arguments
real(dp), intent(inout) :: a, b
real(dp), intent(out) :: c, s
! =====================================================================
! Local Scalars
real(dp) :: anorm, bnorm, scl, sigma, r, z
anorm = abs(a)
bnorm = abs(b)
if( bnorm == zero ) then
c = one
s = zero
b = zero
else if( anorm == zero ) then
c = zero
s = one
a = b
b = one
else
scl = min( safmax, max( safmin, anorm, bnorm ) )
if( anorm > bnorm ) then
sigma = sign(one,a)
else
sigma = sign(one,b)
end if
r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) )
c = a/r
s = b/r
if( anorm > bnorm ) then
z = s
else if( c /= zero ) then
z = one/c
else
z = one
end if
a = r
b = z
end if
return
end subroutine stdlib${ii}$_drotg
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$rotg( a, b, c, s )
use stdlib_blas_constants_${rk}$
!! The computation uses the formulas
!! sigma = sgn(a) if |a| > |b|
!! = sgn(b) if |b| >= |a|
!! r = sigma*sqrt( a**2 + b**2 )
!! c = 1; s = 0 if r = 0
!! c = a/r; s = b/r if r != 0
!! The subroutine also computes
!! z = s if |a| > |b|,
!! = 1/c if |b| >= |a| and c != 0
!! = 1 if c = 0
!! This allows c and s to be reconstructed from z as follows:
!! If z = 1, set c = 0, s = 1.
!! If |z| < 1, set c = sqrt(1 - z**2) and s = z.
!! If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2).
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scaling Constants
! Scalar Arguments
real(${rk}$), intent(inout) :: a, b
real(${rk}$), intent(out) :: c, s
! =====================================================================
! Local Scalars
real(${rk}$) :: anorm, bnorm, scl, sigma, r, z
anorm = abs(a)
bnorm = abs(b)
if( bnorm == zero ) then
c = one
s = zero
b = zero
else if( anorm == zero ) then
c = zero
s = one
a = b
b = one
else
scl = min( safmax, max( safmin, anorm, bnorm ) )
if( anorm > bnorm ) then
sigma = sign(one,a)
else
sigma = sign(one,b)
end if
r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) )
c = a/r
s = b/r
if( anorm > bnorm ) then
z = s
else if( c /= zero ) then
z = one/c
else
z = one
end if
a = r
b = z
end if
return
end subroutine stdlib${ii}$_${ri}$rotg
#:endif
#:endfor
pure module subroutine stdlib${ii}$_crotg( a, b, c, s )
use stdlib_blas_constants_sp
!! The computation uses the formulas
!! |x| = sqrt( Re(x)**2 + Im(x)**2 )
!! sgn(x) = x / |x| if x /= 0
!! = 1 if x = 0
!! c = |a| / sqrt(|a|**2 + |b|**2)
!! s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2)
!! When a and b are real and r /= 0, the formulas simplify to
!! r = sgn(a)*sqrt(|a|**2 + |b|**2)
!! c = a / r
!! s = b / r
!! the same as in SROTG when |a| > |b|. When |b| >= |a|, the
!! sign of c and s will be different from those computed by SROTG
!! if the signs of a and b are not the same.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scaling Constants
! Scalar Arguments
real(sp), intent(out) :: c
complex(sp), intent(inout) :: a
complex(sp), intent(in) :: b
complex(sp), intent(out) :: s
! =====================================================================
! Local Scalars
real(sp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
complex(sp) :: f, fs, g, gs, r, t
! Intrinsic Functions
intrinsic :: abs,aimag,conjg,max,min,real,sqrt
! Statement Functions
real(sp) :: abssq
! Statement Function Definitions
abssq( t ) = real( t,KIND=sp)**2 + aimag( t )**2
! Executable Statements
f = a
g = b
if( g == czero ) then
c = one
s = czero
r = f
else if( f == czero ) then
c = zero
g1 = max( abs(real(g,KIND=sp)), abs(aimag(g)) )
if( g1 > rtmin .and. g1 < rtmax ) then
! use unscaled algorithm
g2 = abssq( g )
d = sqrt( g2 )
s = conjg( g ) / d
r = d
else
! use scaled algorithm
u = min( safmax, max( safmin, g1 ) )
uu = one / u
gs = g*uu
g2 = abssq( gs )
d = sqrt( g2 )
s = conjg( gs ) / d
r = d*u
end if
else
f1 = max( abs(real(f,KIND=sp)), abs(aimag(f)) )
g1 = max( abs(real(g,KIND=sp)), abs(aimag(g)) )
if( f1 > rtmin .and. f1 < rtmax .and. g1 > rtmin .and. g1 < rtmax ) then
! use unscaled algorithm
f2 = abssq( f )
g2 = abssq( g )
h2 = f2 + g2
if( f2 > rtmin .and. h2 < rtmax ) then
d = sqrt( f2*h2 )
else
d = sqrt( f2 )*sqrt( h2 )
end if
p = 1 / d
c = f2*p
s = conjg( g )*( f*p )
r = f*( h2*p )
else
! use scaled algorithm
u = min( safmax, max( safmin, f1, g1 ) )
uu = one / u
gs = g*uu
g2 = abssq( gs )
if( f1*uu < rtmin ) then
! f is not well-scaled when scaled by g1.
! use a different scaling for f.
v = min( safmax, max( safmin, f1 ) )
vv = one / v
w = v * uu
fs = f*vv
f2 = abssq( fs )
h2 = f2*w**2 + g2
else
! otherwise use the same scaling for f and g.
w = one
fs = f*uu
f2 = abssq( fs )
h2 = f2 + g2
end if
if( f2 > rtmin .and. h2 < rtmax ) then
d = sqrt( f2*h2 )
else
d = sqrt( f2 )*sqrt( h2 )
end if
p = 1 / d
c = ( f2*p )*w
s = conjg( gs )*( fs*p )
r = ( fs*( h2*p ) )*u
end if
end if
a = r
return
end subroutine stdlib${ii}$_crotg
pure module subroutine stdlib${ii}$_zrotg( a, b, c, s )
use stdlib_blas_constants_dp
!! The computation uses the formulas
!! |x| = sqrt( Re(x)**2 + Im(x)**2 )
!! sgn(x) = x / |x| if x /= 0
!! = 1 if x = 0
!! c = |a| / sqrt(|a|**2 + |b|**2)
!! s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2)
!! When a and b are real and r /= 0, the formulas simplify to
!! r = sgn(a)*sqrt(|a|**2 + |b|**2)
!! c = a / r
!! s = b / r
!! the same as in DROTG when |a| > |b|. When |b| >= |a|, the
!! sign of c and s will be different from those computed by DROTG
!! if the signs of a and b are not the same.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scaling Constants
! Scalar Arguments
real(dp), intent(out) :: c
complex(dp), intent(inout) :: a
complex(dp), intent(in) :: b
complex(dp), intent(out) :: s
! =====================================================================
! Local Scalars
real(dp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
complex(dp) :: f, fs, g, gs, r, t
! Intrinsic Functions
intrinsic :: abs,aimag,conjg,max,min,real,sqrt
! Statement Functions
real(dp) :: abssq
! Statement Function Definitions
abssq( t ) = real( t,KIND=dp)**2 + aimag( t )**2
! Executable Statements
f = a
g = b
if( g == czero ) then
c = one
s = czero
r = f
else if( f == czero ) then
c = zero
g1 = max( abs(real(g,KIND=dp)), abs(aimag(g)) )
if( g1 > rtmin .and. g1 < rtmax ) then
! use unscaled algorithm
g2 = abssq( g )
d = sqrt( g2 )
s = conjg( g ) / d
r = d
else
! use scaled algorithm
u = min( safmax, max( safmin, g1 ) )
uu = one / u
gs = g*uu
g2 = abssq( gs )
d = sqrt( g2 )
s = conjg( gs ) / d
r = d*u
end if
else
f1 = max( abs(real(f,KIND=dp)), abs(aimag(f)) )
g1 = max( abs(real(g,KIND=dp)), abs(aimag(g)) )
if( f1 > rtmin .and. f1 < rtmax .and. g1 > rtmin .and. g1 < rtmax ) then
! use unscaled algorithm
f2 = abssq( f )
g2 = abssq( g )
h2 = f2 + g2
if( f2 > rtmin .and. h2 < rtmax ) then
d = sqrt( f2*h2 )
else
d = sqrt( f2 )*sqrt( h2 )
end if
p = 1 / d
c = f2*p
s = conjg( g )*( f*p )
r = f*( h2*p )
else
! use scaled algorithm
u = min( safmax, max( safmin, f1, g1 ) )
uu = one / u
gs = g*uu
g2 = abssq( gs )
if( f1*uu < rtmin ) then
! f is not well-scaled when scaled by g1.
! use a different scaling for f.
v = min( safmax, max( safmin, f1 ) )
vv = one / v
w = v * uu
fs = f*vv
f2 = abssq( fs )
h2 = f2*w**2 + g2
else
! otherwise use the same scaling for f and g.
w = one
fs = f*uu
f2 = abssq( fs )
h2 = f2 + g2
end if
if( f2 > rtmin .and. h2 < rtmax ) then
d = sqrt( f2*h2 )
else
d = sqrt( f2 )*sqrt( h2 )
end if
p = 1 / d
c = ( f2*p )*w
s = conjg( gs )*( fs*p )
r = ( fs*( h2*p ) )*u
end if
end if
a = r
return
end subroutine stdlib${ii}$_zrotg
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$rotg( a, b, c, s )
use stdlib_blas_constants_${ck}$
!! The computation uses the formulas
!! |x| = sqrt( Re(x)**2 + Im(x)**2 )
!! sgn(x) = x / |x| if x /= 0
!! = 1 if x = 0
!! c = |a| / sqrt(|a|**2 + |b|**2)
!! s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2)
!! When a and b are real and r /= 0, the formulas simplify to
!! r = sgn(a)*sqrt(|a|**2 + |b|**2)
!! c = a / r
!! s = b / r
!! the same as in DROTG when |a| > |b|. When |b| >= |a|, the
!! sign of c and s will be different from those computed by DROTG
!! if the signs of a and b are not the same.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scaling Constants
! Scalar Arguments
real(${ck}$), intent(out) :: c
complex(${ck}$), intent(inout) :: a
complex(${ck}$), intent(in) :: b
complex(${ck}$), intent(out) :: s
! =====================================================================
! Local Scalars
real(${ck}$) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
complex(${ck}$) :: f, fs, g, gs, r, t
! Intrinsic Functions
intrinsic :: abs,aimag,conjg,max,min,real,sqrt
! Statement Functions
real(${ck}$) :: abssq
! Statement Function Definitions
abssq( t ) = real( t,KIND=${ck}$)**2 + aimag( t )**2
! Executable Statements
f = a
g = b
if( g == czero ) then
c = one
s = czero
r = f
else if( f == czero ) then
c = zero
g1 = max( abs(real(g,KIND=${ck}$)), abs(aimag(g)) )
if( g1 > rtmin .and. g1 < rtmax ) then
! use unscaled algorithm
g2 = abssq( g )
d = sqrt( g2 )
s = conjg( g ) / d
r = d
else
! use scaled algorithm
u = min( safmax, max( safmin, g1 ) )
uu = one / u
gs = g*uu
g2 = abssq( gs )
d = sqrt( g2 )
s = conjg( gs ) / d
r = d*u
end if
else
f1 = max( abs(real(f,KIND=${ck}$)), abs(aimag(f)) )
g1 = max( abs(real(g,KIND=${ck}$)), abs(aimag(g)) )
if( f1 > rtmin .and. f1 < rtmax .and. g1 > rtmin .and. g1 < rtmax ) then
! use unscaled algorithm
f2 = abssq( f )
g2 = abssq( g )
h2 = f2 + g2
if( f2 > rtmin .and. h2 < rtmax ) then
d = sqrt( f2*h2 )
else
d = sqrt( f2 )*sqrt( h2 )
end if
p = 1 / d
c = f2*p
s = conjg( g )*( f*p )
r = f*( h2*p )
else
! use scaled algorithm
u = min( safmax, max( safmin, f1, g1 ) )
uu = one / u
gs = g*uu
g2 = abssq( gs )
if( f1*uu < rtmin ) then
! f is not well-scaled when scaled by g1.
! use a different scaling for f.
v = min( safmax, max( safmin, f1 ) )
vv = one / v
w = v * uu
fs = f*vv
f2 = abssq( fs )
h2 = f2*w**2 + g2
else
! otherwise use the same scaling for f and g.
w = one
fs = f*uu
f2 = abssq( fs )
h2 = f2 + g2
end if
if( f2 > rtmin .and. h2 < rtmax ) then
d = sqrt( f2*h2 )
else
d = sqrt( f2 )*sqrt( h2 )
end if
p = 1 / d
c = ( f2*p )*w
s = conjg( gs )*( fs*p )
r = ( fs*( h2*p ) )*u
end if
end if
a = r
return
end subroutine stdlib${ii}$_${ci}$rotg
#:endif
#:endfor
pure module subroutine stdlib${ii}$_srotm(n,sx,incx,sy,incy,sparam)
use stdlib_blas_constants_sp
!! SROTM applies the modified Givens transformation, \(H\), to the 2-by-N matrix
!! $$ \left[ \begin{array}{c}SX^T\\SY^T\\ \end{array} \right], $$
!! where \(^T\) indicates transpose. The elements of \(SX\) are in
!! SX(LX+I*INCX), I = 0:N-1, where LX = 1 if INCX >= 0, else LX = (-INCX)*N,
!! and similarly for SY using LY and INCY.
!! With SPARAM(1)=SFLAG, \(H\) has one of the following forms:
!! $$ H=\underbrace{\begin{bmatrix}SH_{11} & SH_{12}\\SH_{21} & SH_{22}\end{bmatrix}}_{SFLAG=-1},
!! \underbrace{\begin{bmatrix}1 & SH_{12}\\SH_{21} & 1\end{bmatrix}}_{SFLAG=0},
!! \underbrace{\begin{bmatrix}SH_{11} & 1\\-1 & SH_{22}\end{bmatrix}}_{SFLAG=1},
!! \underbrace{\begin{bmatrix}1 & 0\\0 & 1\end{bmatrix}}_{SFLAG=-2}. $$
!! See SROTMG for a description of data storage in SPARAM.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
real(sp), intent(in) :: sparam(5)
real(sp), intent(inout) :: sx(*), sy(*)
! =====================================================================
! Local Scalars
real(sp) :: sflag, sh11, sh12, sh21, sh22, w, z
integer(${ik}$) :: i, kx, ky, nsteps
! Data Statements
sflag = sparam(1)
if (n<=0 .or. (sflag+two==zero)) return
if (incx==incy.and.incx>0) then
nsteps = n*incx
if (sflag= 0, else LX = (-INCX)*N,
!! and similarly for DY using LY and INCY.
!! With DPARAM(1)=DFLAG, \(H\) has one of the following forms:
!! $$ H=\underbrace{\begin{bmatrix}DH_{11} & DH_{12}\\DH_{21} & DH_{22}\end{bmatrix}}_{DFLAG=-1},
!! \underbrace{\begin{bmatrix}1 & DH_{12}\\DH_{21} & 1\end{bmatrix}}_{DFLAG=0},
!! \underbrace{\begin{bmatrix}DH_{11} & 1\\-1 & DH_{22}\end{bmatrix}}_{DFLAG=1},
!! \underbrace{\begin{bmatrix}1 & 0\\0 & 1\end{bmatrix}}_{DFLAG=-2}. $$
!! See DROTMG for a description of data storage in DPARAM.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
real(dp), intent(in) :: dparam(5)
real(dp), intent(inout) :: dx(*), dy(*)
! =====================================================================
! Local Scalars
real(dp) :: dflag, dh11, dh12, dh21, dh22, w, z
integer(${ik}$) :: i, kx, ky, nsteps
! Data Statements
dflag = dparam(1)
if (n<=0 .or. (dflag+two==zero)) return
if (incx==incy.and.incx>0) then
nsteps = n*incx
if (dflag= 0, else LX = (-INCX)*N,
!! and similarly for DY using LY and INCY.
!! With DPARAM(1)=DFLAG, \(H\) has one of the following forms:
!! $$ H=\underbrace{\begin{bmatrix}DH_{11} & DH_{12}\\DH_{21} & DH_{22}\end{bmatrix}}_{DFLAG=-1},
!! \underbrace{\begin{bmatrix}1 & DH_{12}\\DH_{21} & 1\end{bmatrix}}_{DFLAG=0},
!! \underbrace{\begin{bmatrix}DH_{11} & 1\\-1 & DH_{22}\end{bmatrix}}_{DFLAG=1},
!! \underbrace{\begin{bmatrix}1 & 0\\0 & 1\end{bmatrix}}_{DFLAG=-2}. $$
!! See QROTMG for a description of data storage in DPARAM.
! -- reference blas level1 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
integer(${ik}$), intent(in) :: incx, incy, n
! Array Arguments
real(${rk}$), intent(in) :: dparam(5)
real(${rk}$), intent(inout) :: dx(*), dy(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: dflag, dh11, dh12, dh21, dh22, w, z
integer(${ik}$) :: i, kx, ky, nsteps
! Data Statements
dflag = dparam(1)
if (n<=0 .or. (dflag+two==zero)) return
if (incx==incy.and.incx>0) then
nsteps = n*incx
if (dflagabs(sq2)) then
sh21 = -sy1/sx1
sh12 = sp2/sp1
su = one - sh12*sh21
if (su>zero) then
sflag = zero
sd1 = sd1/su
sd2 = sd2/su
sx1 = sx1*su
else
! this code path if here for safety. we do not expect this
! condition to ever hold except in edge cases with rounding
! errors. see doi: 10.1145/355841.355847
sflag = -one
sh11 = zero
sh12 = zero
sh21 = zero
sh22 = zero
sd1 = zero
sd2 = zero
sx1 = zero
end if
else
if (sq2=gamsq))
if (sflag==zero) then
sh11 = one
sh22 = one
sflag = -one
else
sh21 = -one
sh12 = one
sflag = -one
end if
if (sd1<=rgamsq) then
sd1 = sd1*gam**2
sx1 = sx1/gam
sh11 = sh11/gam
sh12 = sh12/gam
else
sd1 = sd1/gam**2
sx1 = sx1*gam
sh11 = sh11*gam
sh12 = sh12*gam
end if
enddo
end if
if (sd2/=zero) then
do while ( (abs(sd2)<=rgamsq) .or. (abs(sd2)>=gamsq) )
if (sflag==zero) then
sh11 = one
sh22 = one
sflag = -one
else
sh21 = -one
sh12 = one
sflag = -one
end if
if (abs(sd2)<=rgamsq) then
sd2 = sd2*gam**2
sh21 = sh21/gam
sh22 = sh22/gam
else
sd2 = sd2/gam**2
sh21 = sh21*gam
sh22 = sh22*gam
end if
end do
end if
end if
if (sflagabs(dq2)) then
dh21 = -dy1/dx1
dh12 = dp2/dp1
du = one - dh12*dh21
if (du>zero) then
dflag = zero
dd1 = dd1/du
dd2 = dd2/du
dx1 = dx1*du
else
! this code path if here for safety. we do not expect this
! condition to ever hold except in edge cases with rounding
! errors. see doi: 10.1145/355841.355847
dflag = -one
dh11 = zero
dh12 = zero
dh21 = zero
dh22 = zero
dd1 = zero
dd2 = zero
dx1 = zero
end if
else
if (dq2=gamsq))
if (dflag==zero) then
dh11 = one
dh22 = one
dflag = -one
else
dh21 = -one
dh12 = one
dflag = -one
end if
if (dd1<=rgamsq) then
dd1 = dd1*gam**2
dx1 = dx1/gam
dh11 = dh11/gam
dh12 = dh12/gam
else
dd1 = dd1/gam**2
dx1 = dx1*gam
dh11 = dh11*gam
dh12 = dh12*gam
end if
enddo
end if
if (dd2/=zero) then
do while ( (abs(dd2)<=rgamsq) .or. (abs(dd2)>=gamsq) )
if (dflag==zero) then
dh11 = one
dh22 = one
dflag = -one
else
dh21 = -one
dh12 = one
dflag = -one
end if
if (abs(dd2)<=rgamsq) then
dd2 = dd2*gam**2
dh21 = dh21/gam
dh22 = dh22/gam
else
dd2 = dd2/gam**2
dh21 = dh21*gam
dh22 = dh22*gam
end if
end do
end if
end if
if (dflagabs(dq2)) then
dh21 = -dy1/dx1
dh12 = dp2/dp1
du = one - dh12*dh21
if (du>zero) then
dflag = zero
dd1 = dd1/du
dd2 = dd2/du
dx1 = dx1*du
else
! this code path if here for safety. we do not expect this
! condition to ever hold except in edge cases with rounding
! errors. see doi: 10.1145/355841.355847
dflag = -one
dh11 = zero
dh12 = zero
dh21 = zero
dh22 = zero
dd1 = zero
dd2 = zero
dx1 = zero
end if
else
if (dq2=gamsq))
if (dflag==zero) then
dh11 = one
dh22 = one
dflag = -one
else
dh21 = -one
dh12 = one
dflag = -one
end if
if (dd1<=rgamsq) then
dd1 = dd1*gam**2
dx1 = dx1/gam
dh11 = dh11/gam
dh12 = dh12/gam
else
dd1 = dd1/gam**2
dx1 = dx1*gam
dh11 = dh11*gam
dh12 = dh12*gam
end if
enddo
end if
if (dd2/=zero) then
do while ( (abs(dd2)<=rgamsq) .or. (abs(dd2)>=gamsq) )
if (dflag==zero) then
dh11 = one
dh22 = one
dflag = -one
else
dh21 = -one
dh12 = one
dflag = -one
end if
if (abs(dd2)<=rgamsq) then
dd2 = dd2*gam**2
dh21 = dh21/gam
dh22 = dh22/gam
else
dd2 = dd2/gam**2
dh21 = dh21*gam
dh22 = dh22*gam
end if
end do
end if
end if
if (dflag |b|. When |b| >= |a|, the
!! sign of c and s will be different from those computed by SROTG
!! if the signs of a and b are not the same.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine crotg( a, b, c, s )
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(out) :: c
complex(sp), intent(inout) :: a
complex(sp), intent(in) :: b
complex(sp), intent(out) :: s
end subroutine crotg
#:if not 'ilp64' in ik
#else
module procedure stdlib${ii}$_crotg
#:endif
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine drotg( a, b, c, s )
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(inout) :: a,b
real(dp), intent(out) :: c,s
end subroutine drotg
#:if not 'ilp64' in ik
#else
module procedure stdlib${ii}$_drotg
#:endif
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine srotg( a, b, c, s )
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(inout) :: a,b
real(sp), intent(out) :: c,s
end subroutine srotg
#:if not 'ilp64' in ik
#else
module procedure stdlib${ii}$_srotg
#:endif
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine zrotg( a, b, c, s )
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(out) :: c
complex(dp), intent(inout) :: a
complex(dp), intent(in) :: b
complex(dp), intent(out) :: s
end subroutine zrotg
#:if not 'ilp64' in ik
#else
module procedure stdlib${ii}$_zrotg
#:endif
#endif
#:endfor
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib_${ri}$rotg
#:endif
#:endfor
end interface rotg
interface rotm
!! ROTM applies the modified Givens transformation, \(H\), to the 2-by-N matrix
!! $$ \left[ \begin{array}{c}DX^T\\DY^T\\ \end{array} \right], $$
!! where \(^T\) indicates transpose. The elements of \(DX\) are in
!! DX(LX+I*INCX), I = 0:N-1, where LX = 1 if INCX >= 0, else LX = (-INCX)*N,
!! and similarly for DY using LY and INCY.
!! With DPARAM(1)=DFLAG, \(H\) has one of the following forms:
!! $$ H=\underbrace{\begin{bmatrix}DH_{11} & DH_{12}\\DH_{21} & DH_{22}\end{bmatrix}}_{DFLAG=-1},
!! \underbrace{\begin{bmatrix}1 & DH_{12}\\DH_{21} & 1\end{bmatrix}}_{DFLAG=0},
!! \underbrace{\begin{bmatrix}DH_{11} & 1\\-1 & DH_{22}\end{bmatrix}}_{DFLAG=1},
!! \underbrace{\begin{bmatrix}1 & 0\\0 & 1\end{bmatrix}}_{DFLAG=-2}. $$
!! See ROTMG for a description of data storage in DPARAM.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine drotm(n,dx,incx,dy,incy,dparam)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,incy,n
real(dp), intent(in) :: dparam(5)
real(dp), intent(inout) :: dx(*),dy(*)
end subroutine drotm
#else
module procedure stdlib${ii}$_drotm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine srotm(n,sx,incx,sy,incy,sparam)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,incy,n
real(sp), intent(in) :: sparam(5)
real(sp), intent(inout) :: sx(*),sy(*)
end subroutine srotm
#else
module procedure stdlib${ii}$_srotm
#endif
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$rotm
#:endif
#:endfor
#:endfor
end interface rotm
interface rotmg
!! ROTMG Constructs the modified Givens transformation matrix \(H\) which zeros the
!! second component of the 2-vector
!! $$ \left[ {\sqrt{DD_1}\cdot DX_1,\sqrt{DD_2}\cdot DY_2} \right]^T. $$
!! With DPARAM(1)=DFLAG, \(H\) has one of the following forms:
!! $$ H=\underbrace{\begin{bmatrix}DH_{11} & DH_{12}\\DH_{21} & DH_{22}\end{bmatrix}}_{DFLAG=-1},
!! \underbrace{\begin{bmatrix}1 & DH_{12}\\DH_{21} & 1\end{bmatrix}}_{DFLAG=0},
!! \underbrace{\begin{bmatrix}DH_{11} & 1\\-1 & DH_{22}\end{bmatrix}}_{DFLAG=1},
!! \underbrace{\begin{bmatrix}1 & 0\\0 & 1\end{bmatrix}}_{DFLAG=-2}. $$
!! Locations 2-4 of DPARAM contain DH11, DH21, DH12 and DH22 respectively.
!! (Values of 1.0, -1.0, or 0.0 implied by the value of DPARAM(1) are not stored in DPARAM.)
!! The values of parameters GAMSQ and RGAMSQ may be inexact. This is OK as they are only
!! used for testing the size of DD1 and DD2. All actual scaling of data is done using GAM.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine drotmg(dd1,dd2,dx1,dy1,dparam)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(inout) :: dd1,dd2,dx1
real(dp), intent(in) :: dy1
real(dp), intent(out) :: dparam(5)
end subroutine drotmg
#:if not 'ilp64' in ik
#else
module procedure stdlib${ii}$_drotmg
#:endif
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine srotmg(sd1,sd2,sx1,sy1,sparam)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(inout) :: sd1,sd2,sx1
real(sp), intent(in) :: sy1
real(sp), intent(out) :: sparam(5)
end subroutine srotmg
#:if not 'ilp64' in ik
#else
module procedure stdlib_srotmg
#:endif
#endif
#:endfor
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib_${ri}$rotmg
#:endif
#:endfor
end interface rotmg
interface sbmv
!! SBMV 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.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dsbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,beta,a(lda,*),x(*)
integer(${ik}$), intent(in) :: incx,incy,k,lda,n
character, intent(in) :: uplo
real(dp), intent(inout) :: y(*)
end subroutine dsbmv
#else
module procedure stdlib${ii}$_dsbmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ssbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,beta,a(lda,*),x(*)
integer(${ik}$), intent(in) :: incx,incy,k,lda,n
character, intent(in) :: uplo
real(sp), intent(inout) :: y(*)
end subroutine ssbmv
#else
module procedure stdlib${ii}$_ssbmv
#endif
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$sbmv
#:endif
#:endfor
#:endfor
end interface sbmv
interface scal
!! SCAL scales a vector by a constant.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine cscal(n,ca,cx,incx)
import sp,dp,qp,${ik}$,lk
implicit none
complex(sp), intent(in) :: ca
integer(${ik}$), intent(in) :: incx,n
complex(sp), intent(inout) :: cx(*)
end subroutine cscal
#else
module procedure stdlib${ii}$_cscal
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dscal(n,da,dx,incx)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: da
integer(${ik}$), intent(in) :: incx,n
real(dp), intent(inout) :: dx(*)
end subroutine dscal
#else
module procedure stdlib${ii}$_dscal
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine sscal(n,sa,sx,incx)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: sa
integer(${ik}$), intent(in) :: incx,n
real(sp), intent(inout) :: sx(*)
end subroutine sscal
#else
module procedure stdlib${ii}$_sscal
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine zscal(n,za,zx,incx)
import sp,dp,qp,${ik}$,lk
implicit none
complex(dp), intent(in) :: za
integer(${ik}$), intent(in) :: incx,n
complex(dp), intent(inout) :: zx(*)
end subroutine zscal
#else
module procedure stdlib${ii}$_zscal
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$scal
#:endif
#:endfor
#:endfor
end interface scal
interface sdot
!! Compute the inner product of two vectors with extended
!! precision accumulation and result.
!! Returns D.P. dot product accumulated in D.P., for S.P. SX and SY
!! SDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY),
!! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is
!! defined in a similar way using INCY.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#:if WITH_QP
!! Provide a unique interface to accumulate double precision reals
!! into the highest available precision.
module procedure stdlib${ii}$_qsdot
#:elif WITH_XDP
!! Provide a unique interface to accumulate double precision reals
!! into the highest available precision.
module procedure stdlib${ii}$_xsdot
#:endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure real(dp) function dsdot(n,sx,incx,sy,incy)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,incy,n
real(sp), intent(in) :: sx(*),sy(*)
end function dsdot
#else
module procedure stdlib${ii}$_dsdot
#endif
#:endfor
end interface sdot
interface spmv
!! SPMV 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, supplied in packed form.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dspmv(uplo,n,alpha,ap,x,incx,beta,y,incy)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,beta,ap(*),x(*)
integer(${ik}$), intent(in) :: incx,incy,n
character, intent(in) :: uplo
real(dp), intent(inout) :: y(*)
end subroutine dspmv
#else
module procedure stdlib${ii}$_dspmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine sspmv(uplo,n,alpha,ap,x,incx,beta,y,incy)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,beta,ap(*),x(*)
integer(${ik}$), intent(in) :: incx,incy,n
character, intent(in) :: uplo
real(sp), intent(inout) :: y(*)
end subroutine sspmv
#else
module procedure stdlib${ii}$_sspmv
#endif
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$spmv
#:endif
#:endfor
#:endfor
end interface spmv
interface spr
!! SPR performs the symmetric rank 1 operation
!! A := alpha*x*x**T + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n symmetric matrix, supplied in packed form.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dspr(uplo,n,alpha,x,incx,ap)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,x(*)
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: uplo
real(dp), intent(inout) :: ap(*)
end subroutine dspr
#else
module procedure stdlib${ii}$_dspr
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine sspr(uplo,n,alpha,x,incx,ap)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,x(*)
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: uplo
real(sp), intent(inout) :: ap(*)
end subroutine sspr
#else
module procedure stdlib${ii}$_sspr
#endif
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$spr
#:endif
#:endfor
#:endfor
end interface spr
interface spr2
!! SPR2 performs the symmetric rank 2 operation
!! A := alpha*x*y**T + alpha*y*x**T + A,
!! where alpha is a scalar, x and y are n element vectors and A is an
!! n by n symmetric matrix, supplied in packed form.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dspr2(uplo,n,alpha,x,incx,y,incy,ap)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,x(*),y(*)
integer(${ik}$), intent(in) :: incx,incy,n
character, intent(in) :: uplo
real(dp), intent(inout) :: ap(*)
end subroutine dspr2
#else
module procedure stdlib${ii}$_dspr2
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine sspr2(uplo,n,alpha,x,incx,y,incy,ap)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,x(*),y(*)
integer(${ik}$), intent(in) :: incx,incy,n
character, intent(in) :: uplo
real(sp), intent(inout) :: ap(*)
end subroutine sspr2
#else
module procedure stdlib${ii}$_sspr2
#endif
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$spr2
#:endif
#:endfor
#:endfor
end interface spr2
interface srot
!! SROT applies a plane rotation, where the cos and sin (c and s) are real
!! and the vectors cx and cy are complex.
!! jack dongarra, linpack, 3/11/78.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine csrot( n, cx, incx, cy, incy, c, s )
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,incy,n
real(sp), intent(in) :: c,s
complex(sp), intent(inout) :: cx(*),cy(*)
end subroutine csrot
#else
module procedure stdlib${ii}$_csrot
#endif
#:endfor
end interface srot
interface sscal
!! SSCAL scales a complex vector by a real constant.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine csscal(n,sa,cx,incx)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: sa
integer(${ik}$), intent(in) :: incx,n
complex(sp), intent(inout) :: cx(*)
end subroutine csscal
#else
module procedure stdlib${ii}$_csscal
#endif
#:endfor
end interface sscal
interface swap
!! SWAP interchanges two vectors.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine cswap(n,cx,incx,cy,incy)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,incy,n
complex(sp), intent(inout) :: cx(*),cy(*)
end subroutine cswap
#else
module procedure stdlib${ii}$_cswap
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dswap(n,dx,incx,dy,incy)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,incy,n
real(dp), intent(inout) :: dx(*),dy(*)
end subroutine dswap
#else
module procedure stdlib${ii}$_dswap
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine sswap(n,sx,incx,sy,incy)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,incy,n
real(sp), intent(inout) :: sx(*),sy(*)
end subroutine sswap
#else
module procedure stdlib${ii}$_sswap
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine zswap(n,zx,incx,zy,incy)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,incy,n
complex(dp), intent(inout) :: zx(*),zy(*)
end subroutine zswap
#else
module procedure stdlib${ii}$_zswap
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$swap
#:endif
#:endfor
#:endfor
end interface swap
interface symm
!! SYMM performs one of the matrix-matrix operations
!! C := alpha*A*B + beta*C,
!! or
!! C := alpha*B*A + beta*C,
!! where alpha and beta are scalars, A is a symmetric matrix and B and
!! C are m by n matrices.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine csymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
complex(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*)
integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n
character, intent(in) :: side,uplo
complex(sp), intent(inout) :: c(ldc,*)
end subroutine csymm
#else
module procedure stdlib${ii}$_csymm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*)
integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n
character, intent(in) :: side,uplo
real(dp), intent(inout) :: c(ldc,*)
end subroutine dsymm
#else
module procedure stdlib${ii}$_dsymm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ssymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*)
integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n
character, intent(in) :: side,uplo
real(sp), intent(inout) :: c(ldc,*)
end subroutine ssymm
#else
module procedure stdlib${ii}$_ssymm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine zsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
complex(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*)
integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n
character, intent(in) :: side,uplo
complex(dp), intent(inout) :: c(ldc,*)
end subroutine zsymm
#else
module procedure stdlib${ii}$_zsymm
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$symm
#:endif
#:endfor
#:endfor
end interface symm
interface symv
!! SYMV 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.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dsymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,beta,a(lda,*),x(*)
integer(${ik}$), intent(in) :: incx,incy,lda,n
character, intent(in) :: uplo
real(dp), intent(inout) :: y(*)
end subroutine dsymv
#else
module procedure stdlib${ii}$_dsymv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ssymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,beta,a(lda,*),x(*)
integer(${ik}$), intent(in) :: incx,incy,lda,n
character, intent(in) :: uplo
real(sp), intent(inout) :: y(*)
end subroutine ssymv
#else
module procedure stdlib${ii}$_ssymv
#endif
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$symv
#:endif
#:endfor
#:endfor
end interface symv
interface syr
!! SYR performs the symmetric rank 1 operation
!! A := alpha*x*x**T + A,
!! where alpha is a real scalar, x is an n element vector and A is an
!! n by n symmetric matrix.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dsyr(uplo,n,alpha,x,incx,a,lda)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,x(*)
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: uplo
real(dp), intent(inout) :: a(lda,*)
end subroutine dsyr
#else
module procedure stdlib${ii}$_dsyr
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ssyr(uplo,n,alpha,x,incx,a,lda)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,x(*)
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: uplo
real(sp), intent(inout) :: a(lda,*)
end subroutine ssyr
#else
module procedure stdlib${ii}$_ssyr
#endif
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$syr
#:endif
#:endfor
#:endfor
end interface syr
interface syr2
!! SYR2 performs the symmetric rank 2 operation
!! A := alpha*x*y**T + alpha*y*x**T + A,
!! where alpha is a scalar, x and y are n element vectors and A is an n
!! by n symmetric matrix.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dsyr2(uplo,n,alpha,x,incx,y,incy,a,lda)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,x(*),y(*)
integer(${ik}$), intent(in) :: incx,incy,lda,n
character, intent(in) :: uplo
real(dp), intent(inout) :: a(lda,*)
end subroutine dsyr2
#else
module procedure stdlib${ii}$_dsyr2
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ssyr2(uplo,n,alpha,x,incx,y,incy,a,lda)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,x(*),y(*)
integer(${ik}$), intent(in) :: incx,incy,lda,n
character, intent(in) :: uplo
real(sp), intent(inout) :: a(lda,*)
end subroutine ssyr2
#else
module procedure stdlib${ii}$_ssyr2
#endif
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$syr2
#:endif
#:endfor
#:endfor
end interface syr2
interface syr2k
!! SYR2K performs one of the symmetric rank 2k operations
!! C := alpha*A*B**T + alpha*B*A**T + beta*C,
!! or
!! C := alpha*A**T*B + alpha*B**T*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.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine csyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
complex(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*)
integer(${ik}$), intent(in) :: k,lda,ldb,ldc,n
character, intent(in) :: trans,uplo
complex(sp), intent(inout) :: c(ldc,*)
end subroutine csyr2k
#else
module procedure stdlib${ii}$_csyr2k
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*)
integer(${ik}$), intent(in) :: k,lda,ldb,ldc,n
character, intent(in) :: trans,uplo
real(dp), intent(inout) :: c(ldc,*)
end subroutine dsyr2k
#else
module procedure stdlib${ii}$_dsyr2k
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ssyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*)
integer(${ik}$), intent(in) :: k,lda,ldb,ldc,n
character, intent(in) :: trans,uplo
real(sp), intent(inout) :: c(ldc,*)
end subroutine ssyr2k
#else
module procedure stdlib${ii}$_ssyr2k
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine zsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
complex(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*)
integer(${ik}$), intent(in) :: k,lda,ldb,ldc,n
character, intent(in) :: trans,uplo
complex(dp), intent(inout) :: c(ldc,*)
end subroutine zsyr2k
#else
module procedure stdlib${ii}$_zsyr2k
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$syr2k
#:endif
#:endfor
#:endfor
end interface syr2k
interface syrk
!! SYRK performs one of the symmetric rank k operations
!! C := alpha*A*A**T + beta*C,
!! or
!! C := alpha*A**T*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.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine csyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
complex(sp), intent(in) :: alpha,beta,a(lda,*)
integer(${ik}$), intent(in) :: k,lda,ldc,n
character, intent(in) :: trans,uplo
complex(sp), intent(inout) :: c(ldc,*)
end subroutine csyrk
#else
module procedure stdlib${ii}$_csyrk
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,beta,a(lda,*)
integer(${ik}$), intent(in) :: k,lda,ldc,n
character, intent(in) :: trans,uplo
real(dp), intent(inout) :: c(ldc,*)
end subroutine dsyrk
#else
module procedure stdlib${ii}$_dsyrk
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ssyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,beta,a(lda,*)
integer(${ik}$), intent(in) :: k,lda,ldc,n
character, intent(in) :: trans,uplo
real(sp), intent(inout) :: c(ldc,*)
end subroutine ssyrk
#else
module procedure stdlib${ii}$_ssyrk
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine zsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc)
import sp,dp,qp,${ik}$,lk
implicit none
complex(dp), intent(in) :: alpha,beta,a(lda,*)
integer(${ik}$), intent(in) :: k,lda,ldc,n
character, intent(in) :: trans,uplo
complex(dp), intent(inout) :: c(ldc,*)
end subroutine zsyrk
#else
module procedure stdlib${ii}$_zsyrk
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$syrk
#:endif
#:endfor
#:endfor
end interface syrk
interface tbmv
!! TBMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular band matrix, with ( k + 1 ) diagonals.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ctbmv(uplo,trans,diag,n,k,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,k,lda,n
character, intent(in) :: diag,trans,uplo
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: x(*)
end subroutine ctbmv
#else
module procedure stdlib${ii}$_ctbmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dtbmv(uplo,trans,diag,n,k,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,k,lda,n
character, intent(in) :: diag,trans,uplo
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: x(*)
end subroutine dtbmv
#else
module procedure stdlib${ii}$_dtbmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine stbmv(uplo,trans,diag,n,k,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,k,lda,n
character, intent(in) :: diag,trans,uplo
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: x(*)
end subroutine stbmv
#else
module procedure stdlib${ii}$_stbmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ztbmv(uplo,trans,diag,n,k,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,k,lda,n
character, intent(in) :: diag,trans,uplo
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: x(*)
end subroutine ztbmv
#else
module procedure stdlib${ii}$_ztbmv
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$tbmv
#:endif
#:endfor
#:endfor
end interface tbmv
interface tbsv
!! TBSV solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ctbsv(uplo,trans,diag,n,k,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,k,lda,n
character, intent(in) :: diag,trans,uplo
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: x(*)
end subroutine ctbsv
#else
module procedure stdlib${ii}$_ctbsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dtbsv(uplo,trans,diag,n,k,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,k,lda,n
character, intent(in) :: diag,trans,uplo
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: x(*)
end subroutine dtbsv
#else
module procedure stdlib${ii}$_dtbsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine stbsv(uplo,trans,diag,n,k,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,k,lda,n
character, intent(in) :: diag,trans,uplo
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: x(*)
end subroutine stbsv
#else
module procedure stdlib${ii}$_stbsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ztbsv(uplo,trans,diag,n,k,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,k,lda,n
character, intent(in) :: diag,trans,uplo
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: x(*)
end subroutine ztbsv
#else
module procedure stdlib${ii}$_ztbsv
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$tbsv
#:endif
#:endfor
#:endfor
end interface tbsv
interface tpmv
!! TPMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix, supplied in packed form.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ctpmv(uplo,trans,diag,n,ap,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: diag,trans,uplo
complex(sp), intent(in) :: ap(*)
complex(sp), intent(inout) :: x(*)
end subroutine ctpmv
#else
module procedure stdlib${ii}$_ctpmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dtpmv(uplo,trans,diag,n,ap,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: diag,trans,uplo
real(dp), intent(in) :: ap(*)
real(dp), intent(inout) :: x(*)
end subroutine dtpmv
#else
module procedure stdlib${ii}$_dtpmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine stpmv(uplo,trans,diag,n,ap,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: diag,trans,uplo
real(sp), intent(in) :: ap(*)
real(sp), intent(inout) :: x(*)
end subroutine stpmv
#else
module procedure stdlib${ii}$_stpmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ztpmv(uplo,trans,diag,n,ap,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: diag,trans,uplo
complex(dp), intent(in) :: ap(*)
complex(dp), intent(inout) :: x(*)
end subroutine ztpmv
#else
module procedure stdlib${ii}$_ztpmv
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$tpmv
#:endif
#:endfor
#:endfor
end interface tpmv
interface tpsv
!! TPSV solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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 matrix, supplied in packed form.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ctpsv(uplo,trans,diag,n,ap,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: diag,trans,uplo
complex(sp), intent(in) :: ap(*)
complex(sp), intent(inout) :: x(*)
end subroutine ctpsv
#else
module procedure stdlib${ii}$_ctpsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dtpsv(uplo,trans,diag,n,ap,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: diag,trans,uplo
real(dp), intent(in) :: ap(*)
real(dp), intent(inout) :: x(*)
end subroutine dtpsv
#else
module procedure stdlib${ii}$_dtpsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine stpsv(uplo,trans,diag,n,ap,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: diag,trans,uplo
real(sp), intent(in) :: ap(*)
real(sp), intent(inout) :: x(*)
end subroutine stpsv
#else
module procedure stdlib${ii}$_stpsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ztpsv(uplo,trans,diag,n,ap,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,n
character, intent(in) :: diag,trans,uplo
complex(dp), intent(in) :: ap(*)
complex(dp), intent(inout) :: x(*)
end subroutine ztpsv
#else
module procedure stdlib${ii}$_ztpsv
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$tpsv
#:endif
#:endfor
#:endfor
end interface tpsv
interface trmm
!! TRMM 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**T or op( A ) = A**H.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ctrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
import sp,dp,qp,${ik}$,lk
implicit none
complex(sp), intent(in) :: alpha,a(lda,*)
integer(${ik}$), intent(in) :: lda,ldb,m,n
character, intent(in) :: diag,side,transa,uplo
complex(sp), intent(inout) :: b(ldb,*)
end subroutine ctrmm
#else
module procedure stdlib${ii}$_ctrmm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dtrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,a(lda,*)
integer(${ik}$), intent(in) :: lda,ldb,m,n
character, intent(in) :: diag,side,transa,uplo
real(dp), intent(inout) :: b(ldb,*)
end subroutine dtrmm
#else
module procedure stdlib${ii}$_dtrmm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine strmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,a(lda,*)
integer(${ik}$), intent(in) :: lda,ldb,m,n
character, intent(in) :: diag,side,transa,uplo
real(sp), intent(inout) :: b(ldb,*)
end subroutine strmm
#else
module procedure stdlib${ii}$_strmm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ztrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
import sp,dp,qp,${ik}$,lk
implicit none
complex(dp), intent(in) :: alpha,a(lda,*)
integer(${ik}$), intent(in) :: lda,ldb,m,n
character, intent(in) :: diag,side,transa,uplo
complex(dp), intent(inout) :: b(ldb,*)
end subroutine ztrmm
#else
module procedure stdlib${ii}$_ztrmm
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$trmm
#:endif
#:endfor
#:endfor
end interface trmm
interface trmv
!! TRMV performs one of the matrix-vector operations
!! x := A*x, or x := A**T*x, or x := A**H*x,
!! where x is an n element vector and A is an n by n unit, or non-unit,
!! upper or lower triangular matrix.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ctrmv(uplo,trans,diag,n,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: diag,trans,uplo
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: x(*)
end subroutine ctrmv
#else
module procedure stdlib${ii}$_ctrmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dtrmv(uplo,trans,diag,n,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: diag,trans,uplo
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: x(*)
end subroutine dtrmv
#else
module procedure stdlib${ii}$_dtrmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine strmv(uplo,trans,diag,n,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: diag,trans,uplo
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: x(*)
end subroutine strmv
#else
module procedure stdlib${ii}$_strmv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ztrmv(uplo,trans,diag,n,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: diag,trans,uplo
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: x(*)
end subroutine ztrmv
#else
module procedure stdlib${ii}$_ztrmv
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$trmv
#:endif
#:endfor
#:endfor
end interface trmv
interface trsm
!! TRSM 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**T or op( A ) = A**H.
!! The matrix X is overwritten on B.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ctrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
import sp,dp,qp,${ik}$,lk
implicit none
complex(sp), intent(in) :: alpha,a(lda,*)
integer(${ik}$), intent(in) :: lda,ldb,m,n
character, intent(in) :: diag,side,transa,uplo
complex(sp), intent(inout) :: b(ldb,*)
end subroutine ctrsm
#else
module procedure stdlib${ii}$_ctrsm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dtrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
import sp,dp,qp,${ik}$,lk
implicit none
real(dp), intent(in) :: alpha,a(lda,*)
integer(${ik}$), intent(in) :: lda,ldb,m,n
character, intent(in) :: diag,side,transa,uplo
real(dp), intent(inout) :: b(ldb,*)
end subroutine dtrsm
#else
module procedure stdlib${ii}$_dtrsm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine strsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
import sp,dp,qp,${ik}$,lk
implicit none
real(sp), intent(in) :: alpha,a(lda,*)
integer(${ik}$), intent(in) :: lda,ldb,m,n
character, intent(in) :: diag,side,transa,uplo
real(sp), intent(inout) :: b(ldb,*)
end subroutine strsm
#else
module procedure stdlib${ii}$_strsm
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ztrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb)
import sp,dp,qp,${ik}$,lk
implicit none
complex(dp), intent(in) :: alpha,a(lda,*)
integer(${ik}$), intent(in) :: lda,ldb,m,n
character, intent(in) :: diag,side,transa,uplo
complex(dp), intent(inout) :: b(ldb,*)
end subroutine ztrsm
#else
module procedure stdlib${ii}$_ztrsm
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$trsm
#:endif
#:endfor
#:endfor
end interface trsm
interface trsv
!! TRSV solves one of the systems of equations
!! A*x = b, or A**T*x = b, or A**H*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 matrix.
!! No test for singularity or near-singularity is included in this
!! routine. Such tests must be performed before calling this routine.
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ctrsv(uplo,trans,diag,n,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: diag,trans,uplo
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(inout) :: x(*)
end subroutine ctrsv
#else
module procedure stdlib${ii}$_ctrsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine dtrsv(uplo,trans,diag,n,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: diag,trans,uplo
real(dp), intent(in) :: a(lda,*)
real(dp), intent(inout) :: x(*)
end subroutine dtrsv
#else
module procedure stdlib${ii}$_dtrsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine strsv(uplo,trans,diag,n,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: diag,trans,uplo
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: x(*)
end subroutine strsv
#else
module procedure stdlib${ii}$_strsv
#endif
#ifdef STDLIB_EXTERNAL_BLAS${ii}$
pure subroutine ztrsv(uplo,trans,diag,n,a,lda,x,incx)
import sp,dp,qp,${ik}$,lk
implicit none
integer(${ik}$), intent(in) :: incx,lda,n
character, intent(in) :: diag,trans,uplo
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(inout) :: x(*)
end subroutine ztrsv
#else
module procedure stdlib${ii}$_ztrsv
#endif
#:for rk,rt,ri in RC_KINDS_TYPES
#:if not rk in ["sp","dp"]
module procedure stdlib${ii}$_${ri}$trsv
#:endif
#:endfor
#:endfor
end interface trsv
end module stdlib_linalg_blas
fortran-lang-stdlib-0ede301/src/blas/stdlib_blas_level3_sym.fypp 0000664 0001750 0001750 00000340052 15135654166 025226 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_blas) stdlib_blas_level3_sym
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_ssyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc)
use stdlib_blas_constants_sp
!! SSYRK performs one of the symmetric rank k operations
!! C := alpha*A*A**T + beta*C,
!! or
!! C := alpha*A**T*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.
! -- reference blas level3 routine --
! -- reference blas is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
! Scalar Arguments
real(sp), intent(in) :: alpha, beta
integer(${ik}$), intent(in) :: k, lda, ldc, n
character, intent(in) :: trans, uplo
! Array Arguments
real(sp), intent(in) :: a(lda,*)
real(sp), intent(inout) :: c(ldc,*)
! =====================================================================
! Intrinsic Functions
intrinsic :: max
! Local Scalars
real(sp) :: temp
integer(${ik}$) :: i, info, j, l, nrowa
logical(lk) :: upper
! test the input parameters.
if (stdlib_lsame(trans,'N')) then
nrowa = n
else
nrowa = k
end if
upper = stdlib_lsame(uplo,'U')
info = 0
if ((.not.upper) .and. (.not.stdlib_lsame(uplo,'L'))) then
info = 1
else if ((.not.stdlib_lsame(trans,'N')) .and.(.not.stdlib_lsame(trans,'T')) .and.(&
.not.stdlib_lsame(trans,'C'))) then
info = 2
else if (n<0) then
info = 3
else if (k<0) then
info = 4
else if (lda Version: experimental
!>
!> Format strings with edit descriptors for each type and kind
!> ([Specification](../page/specs/stdlib_io.html))
character(*), parameter :: &
!> Format string for integers
FMT_INT = '(i0)', &
!> Format string for single precision real numbers
FMT_REAL_SP = '(es15.8e2)', &
!> Format string for souble precision real numbers
FMT_REAL_DP = '(es24.16e3)', &
!> Format string for extended double precision real numbers
FMT_REAL_XDP = '(es26.18e3)', &
!> Format string for quadruple precision real numbers
FMT_REAL_QP = '(es44.35e4)', &
!> Format string for single precision complex numbers
FMT_COMPLEX_SP = '(es15.08e2,1x,es15.08e2)', &
!> Format string for double precision complex numbers
FMT_COMPLEX_DP = '(es24.16e3,1x,es24.16e3)', &
!> Format string for extended double precision complex numbers
FMT_COMPLEX_XDP = '(es26.18e3,1x,es26.18e3)', &
!> Format string for quadruple precision complex numbers
FMT_COMPLEX_QP = '(es44.35e4,1x,es44.35e4)'
end module stdlib_io_aux
fortran-lang-stdlib-0ede301/src/core/stdlib_error.fypp 0000664 0001750 0001750 00000054644 15135654166 023314 0 ustar alastair alastair #:include "common.fypp"
#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES
module stdlib_error
!! Provides support for catching and handling errors
!! ([Specification](../page/specs/stdlib_error.html))
use, intrinsic :: iso_fortran_env, only: stderr => error_unit, ilp => int32
use stdlib_optval, only: optval
use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp, lk
implicit none
private
interface ! f{08,18}estop.f90
module subroutine error_stop(msg, code)
!! version: experimental
!!
!! Provides a call to `error stop` and allows the user to specify a code and message
!! ([Specification](..//page/specs/stdlib_error.html#description_1))
character(*), intent(in) :: msg
integer, intent(in), optional :: code
end subroutine error_stop
end interface
public :: check, error_stop
!> Version: experimental
!>
!> A fixed-storage state variable for error handling of linear algebra routines
public :: state_type
!> Version: experimental
!>
!> Interfaces for comparison operators of error states with integer flags
public :: operator(==),operator(/=)
public :: operator(<),operator(<=)
public :: operator(>),operator(>=)
!> Base state return types for
integer(ilp),parameter,public :: STDLIB_SUCCESS = 0_ilp
integer(ilp),parameter,public :: STDLIB_VALUE_ERROR = -1_ilp
integer(ilp),parameter,public :: STDLIB_LINALG_ERROR = -2_ilp
integer(ilp),parameter,public :: STDLIB_INTERNAL_ERROR = -3_ilp
integer(ilp),parameter,public :: STDLIB_IO_ERROR = -4_ilp
integer(ilp),parameter,public :: STDLIB_FS_ERROR = -5_ilp
!> Use fixed-size character storage for performance
integer(ilp),parameter :: MSG_LENGTH = 512_ilp
integer(ilp),parameter :: NAME_LENGTH = 32_ilp
!> `state_type` defines a general state return type for a
!> stdlib routine. State contains a status flag, a comment, and a
!> procedure specifier that can be used to mark where the error happened
type :: state_type
!> The current exit state
integer(ilp) :: state = STDLIB_SUCCESS
!> Message associated to the current state
character(len=MSG_LENGTH) :: message = repeat(' ',MSG_LENGTH)
!> Location of the state change
character(len=NAME_LENGTH) :: where_at = repeat(' ',NAME_LENGTH)
contains
!> Cleanup
procedure :: destroy => state_destroy
!> Parse error constructor
procedure, private :: state_parse_at_location
procedure, private :: state_parse_arguments
generic :: parse => state_parse_at_location, &
state_parse_arguments
!> Print error message
procedure :: print => state_print
procedure :: print_msg => state_message
!> State properties
procedure :: ok => state_is_ok
procedure :: error => state_is_error
!> Handle optional error message
procedure :: handle => error_handling
end type state_type
!> Comparison operators
interface operator(==)
module procedure state_eq_flag
module procedure flag_eq_state
end interface
interface operator(/=)
module procedure state_neq_flag
module procedure flag_neq_state
end interface
interface operator(<)
module procedure state_lt_flag
module procedure flag_lt_state
end interface
interface operator(<=)
module procedure state_le_flag
module procedure flag_le_state
end interface
interface operator(>)
module procedure state_gt_flag
module procedure flag_gt_state
end interface
interface operator(>=)
module procedure state_ge_flag
module procedure flag_ge_state
end interface
!> Assignment operator
interface assignment(=)
module procedure state_assign_state
end interface assignment(=)
interface state_type
module procedure new_state
module procedure new_state_nowhere
end interface state_type
!> Format strings with edit descriptors for each type and kind
!> cannot be retrieved from stdlib_io due to circular dependencies
character(*), parameter :: &
FMT_INT = '(i0)', &
FMT_REAL_SP = '(es15.8e2)', &
FMT_REAL_DP = '(es24.16e3)', &
FMT_REAL_XDP = '(es26.18e3)', &
FMT_REAL_QP = '(es44.35e4)', &
FMT_COMPLEX_SP = '(es15.8e2,1x,es15.8e2)', &
FMT_COMPLEX_DP = '(es24.16e3,1x,es24.16e3)', &
FMT_COMPLEX_XDP = '(es26.18e3,1x,es26.18e3)', &
FMT_COMPLEX_QP = '(es44.35e4,1x,es44.35e4)'
contains
subroutine check(condition, msg, code, warn)
!! version: experimental
!!
!! Checks the value of a logical condition
!! ([Specification](../page/specs/stdlib_error.html#description))
!!
!!##### Behavior
!!
!! If `condition == .false.` and:
!!
!! * No other arguments are provided, it stops the program with the default
!! message and exit code `1`;
!! * `msg` is provided, it prints the value of `msg`;
!! * `code` is provided, it stops the program with the given exit code;
!! * `warn` is provided and `.true.`, it doesn't stop the program and prints
!! the message.
!!
!!##### Examples
!!
!!* If `a /= 5`, stops the program with exit code `1`
!! and prints `Check failed.`
!!``` fortran
!! call check(a == 5)
!!```
!!
!!* As above, but prints `a == 5 failed`.
!!``` fortran
!! call check(a == 5, msg='a == 5 failed.')
!!```
!!
!!* As above, but doesn't stop the program.
!!``` fortran
!! call check(a == 5, msg='a == 5 failed.', warn=.true.)
!!```
!!
!!* As example #2, but stops the program with exit code `77`
!!``` fortran
!! call check(a == 5, msg='a == 5 failed.', code=77)
!!```
!
! Arguments
! ---------
logical, intent(in) :: condition
character(*), intent(in), optional :: msg
integer, intent(in), optional :: code
logical, intent(in), optional :: warn
character(*), parameter :: msg_default = 'Check failed.'
if (.not. condition) then
if (optval(warn, .false.)) then
write(stderr,*) optval(msg, msg_default)
else
call error_stop(optval(msg, msg_default), optval(code, 1))
end if
end if
end subroutine check
!> Cleanup the object
elemental subroutine state_destroy(this)
class(state_type),intent(inout) :: this
this%state = STDLIB_SUCCESS
this%message = repeat(' ',len(this%message))
this%where_at = repeat(' ',len(this%where_at))
end subroutine state_destroy
!> Interface to print stdlib error messages
pure function state_flag_message(flag) result(msg)
integer(ilp),intent(in) :: flag
character(len=:),allocatable :: msg
select case (flag)
case (STDLIB_SUCCESS); msg = 'Success!'
case (STDLIB_VALUE_ERROR); msg = 'Value Error'
case (STDLIB_LINALG_ERROR); msg = 'Linear Algebra Error'
case (STDLIB_IO_ERROR); msg = 'I/O Error'
case (STDLIB_FS_ERROR); msg = 'Filesystem Error'
case (STDLIB_INTERNAL_ERROR); msg = 'Internal Error'
case default; msg = 'INVALID/UNKNOWN STATE FLAG'
end select
end function state_flag_message
!> Return a formatted message
pure function state_message(this) result(msg)
class(state_type),intent(in) :: this
character(len=:),allocatable :: msg
if (this%state == STDLIB_SUCCESS) then
msg = 'Success!'
else
msg = state_flag_message(this%state)//': '//trim(this%message)
end if
end function state_message
!> Flow control: on output flag present, return it; otherwise, halt on error
pure subroutine error_handling(ierr,ierr_out)
class(state_type), intent(in) :: ierr
class(state_type), optional, intent(inout) :: ierr_out
character(len=:),allocatable :: err_msg
if (present(ierr_out)) then
! Return error flag
ierr_out = ierr
elseif (ierr%error()) then
err_msg = ierr%print()
error stop err_msg
end if
end subroutine error_handling
!> Produce a nice error string
pure function state_print(this) result(msg)
class(state_type),intent(in) :: this
character(len=:),allocatable :: msg
if (len_trim(this%where_at) > 0) then
msg = '['//trim(this%where_at)//'] returned '//this%print_msg()
elseif (this%error()) then
msg = 'Error encountered: '//this%print_msg()
else
msg = this%print_msg()
end if
end function state_print
!> Check if the current state is successful
elemental logical(lk) function state_is_ok(this)
class(state_type),intent(in) :: this
state_is_ok = this%state == STDLIB_SUCCESS
end function state_is_ok
!> Check if the current state is an error state
elemental logical(lk) function state_is_error(this)
class(state_type),intent(in) :: this
state_is_error = this%state /= STDLIB_SUCCESS
end function state_is_error
!> Compare an error state with an integer flag
elemental logical(lk) function state_eq_flag(err,flag)
class(state_type),intent(in) :: err
integer,intent(in) :: flag
state_eq_flag = err%state == flag
end function state_eq_flag
!> Compare an integer flag with the error state
elemental logical(lk) function flag_eq_state(flag,err)
integer,intent(in) :: flag
class(state_type),intent(in) :: err
flag_eq_state = err%state == flag
end function flag_eq_state
!> Compare the error state with an integer flag
elemental logical(lk) function state_neq_flag(err,flag)
class(state_type),intent(in) :: err
integer,intent(in) :: flag
state_neq_flag = .not. state_eq_flag(err,flag)
end function state_neq_flag
!> Compare an integer flag with the error state
elemental logical(lk) function flag_neq_state(flag,err)
integer,intent(in) :: flag
class(state_type),intent(in) :: err
flag_neq_state = .not. state_eq_flag(err,flag)
end function flag_neq_state
!> Compare the error state with an integer flag
elemental logical(lk) function state_lt_flag(err,flag)
class(state_type),intent(in) :: err
integer,intent(in) :: flag
state_lt_flag = err%state < flag
end function state_lt_flag
!> Compare the error state with an integer flag
elemental logical(lk) function state_le_flag(err,flag)
class(state_type),intent(in) :: err
integer,intent(in) :: flag
state_le_flag = err%state <= flag
end function state_le_flag
!> Compare an integer flag with the error state
elemental logical(lk) function flag_lt_state(flag,err)
integer,intent(in) :: flag
class(state_type),intent(in) :: err
flag_lt_state = err%state < flag
end function flag_lt_state
!> Compare an integer flag with the error state
elemental logical(lk) function flag_le_state(flag,err)
integer,intent(in) :: flag
class(state_type),intent(in) :: err
flag_le_state = err%state <= flag
end function flag_le_state
!> Compare the error state with an integer flag
elemental logical(lk) function state_gt_flag(err,flag)
class(state_type),intent(in) :: err
integer,intent(in) :: flag
state_gt_flag = err%state > flag
end function state_gt_flag
!> Compare the error state with an integer flag
elemental logical(lk) function state_ge_flag(err,flag)
class(state_type),intent(in) :: err
integer,intent(in) :: flag
state_ge_flag = err%state >= flag
end function state_ge_flag
!> Compare an integer flag with the error state
elemental logical(lk) function flag_gt_state(flag,err)
integer,intent(in) :: flag
class(state_type),intent(in) :: err
flag_gt_state = err%state > flag
end function flag_gt_state
!> Compare an integer flag with the error state
elemental logical(lk) function flag_ge_state(flag,err)
integer,intent(in) :: flag
class(state_type),intent(in) :: err
flag_ge_state = err%state >= flag
end function flag_ge_state
!> Assign a state type to another
elemental subroutine state_assign_state(to, from)
class(state_type), intent(inout) :: to
class(state_type), intent(in) :: from
to%state = from%state
to%message = from%message
to%where_at = from%where_at
end subroutine state_assign_state
!> Append a generic value to the error flag (rank-agnostic)
pure subroutine appendr(msg,a,prefix)
class(*),optional,intent(in) :: a(..)
character(len=*),intent(inout) :: msg
character,optional,intent(in) :: prefix
if (present(a)) then
select rank (v=>a)
rank (0)
call append (msg,v,prefix)
rank (1)
call appendv(msg,v)
rank default
msg = trim(msg)//' '
end select
endif
end subroutine appendr
! Append a generic value to the error flag
pure subroutine append(msg,a,prefix)
class(*),intent(in) :: a
character(len=*),intent(inout) :: msg
character,optional,intent(in) :: prefix
character(len=MSG_LENGTH) :: buffer,buffer2
character(len=2) :: sep
integer :: ls
! Do not add separator if this is the first instance
sep = ' '
ls = merge(1,0,len_trim(msg) > 0)
if (present(prefix)) then
ls = ls + 1
sep(ls:ls) = prefix
end if
select type (aa => a)
!> String type
type is (character(len=*))
msg = trim(msg)//sep(:ls)//aa
!> Numeric types
#:for k1, t1 in KINDS_TYPES
type is (${t1}$)
#:if 'complex' in t1
write (buffer, FMT_REAL_${k1}$) aa%re
write (buffer2,FMT_REAL_${k1}$) aa%im
msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')'
#:else
#:if 'real' in t1
write (buffer,FMT_REAL_${k1}$) aa
#:else
write (buffer,FMT_INT) aa
#:endif
msg = trim(msg)//sep(:ls)//trim(adjustl(buffer))
#:endif
#:endfor
class default
msg = trim(msg)//' '
end select
end subroutine append
!> Append a generic vector to the error flag
pure subroutine appendv(msg,a)
class(*),intent(in) :: a(:)
character(len=*),intent(inout) :: msg
integer :: j,ls
character(len=MSG_LENGTH) :: buffer,buffer2,buffer_format
character(len=2) :: sep
if (size(a) <= 0) return
! Default: separate elements with one space
sep = ' '
ls = 1
! Open bracket
msg = trim(msg)//' ['
! Do not call append(msg(aa(j))), it will crash gfortran
select type (aa => a)
!> Strings (cannot use string_type due to `sequence`)
type is (character(len=*))
msg = trim(msg)//adjustl(aa(1))
do j = 2,size(a)
msg = trim(msg)//sep(:ls)//adjustl(aa(j))
end do
!> Numeric types
#:for k1, t1 in KINDS_TYPES
type is (${t1}$)
#:if 'complex' in t1
write (buffer,FMT_REAL_${k1}$) aa(1)%re
write (buffer2,FMT_REAL_${k1}$) aa(1)%im
msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')'
do j = 2,size(a)
write (buffer,FMT_REAL_${k1}$) aa(j)%re
write (buffer2,FMT_REAL_${k1}$) aa(j)%im
msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')'
end do
#:else
#:if 'real' in t1
buffer_format = FMT_REAL_${k1}$
#:else
buffer_format = FMT_INT
#:endif
write (buffer,buffer_format) aa(1)
msg = trim(msg)//adjustl(buffer)
do j = 2,size(a)
write (buffer,buffer_format) aa(j)
msg = trim(msg)//sep(:ls)//adjustl(buffer)
end do
msg = trim(msg)//sep(:ls)//trim(adjustl(buffer))
#:endif
#:endfor
class default
msg = trim(msg)//' '
end select
! Close bracket
msg = trim(msg)//']'
end subroutine appendv
!> Error creation message, with location location
pure type(state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
!> Location
character(len=*),intent(in) :: where_at
!> Input error flag
integer,intent(in) :: flag
!> Optional rank-agnostic arguments
class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
! Init object
call new_state%parse(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
end function new_state
!> Error creation message, from N input variables (numeric or strings)
pure type(state_type) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) &
result(new_state)
!> Input error flag
integer,intent(in) :: flag
!> Optional rank-agnostic arguments
class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
! Init object
call new_state%parse(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
end function new_state_nowhere
!> Parse a generic list of arguments provided to the error constructor
pure subroutine state_parse_at_location(new_state,where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
!> The current state variable
class(state_type), intent(inout) :: new_state
!> Error Location
character(len=*),intent(in) :: where_at
!> Input error flag
integer,intent(in) :: flag
!> Optional rank-agnostic arguments
class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
! Init object
call new_state%destroy()
!> Set error flag
new_state%state = flag
!> Set chain
new_state%message = ""
call appendr(new_state%message,a1)
call appendr(new_state%message,a2)
call appendr(new_state%message,a3)
call appendr(new_state%message,a4)
call appendr(new_state%message,a5)
call appendr(new_state%message,a6)
call appendr(new_state%message,a7)
call appendr(new_state%message,a8)
call appendr(new_state%message,a9)
call appendr(new_state%message,a10)
call appendr(new_state%message,a11)
call appendr(new_state%message,a12)
call appendr(new_state%message,a13)
call appendr(new_state%message,a14)
call appendr(new_state%message,a15)
call appendr(new_state%message,a16)
call appendr(new_state%message,a17)
call appendr(new_state%message,a18)
call appendr(new_state%message,a19)
call appendr(new_state%message,a20)
!> Add location
if (len_trim(where_at) > 0) new_state%where_at = adjustl(where_at)
end subroutine state_parse_at_location
!> Parse a generic list of arguments provided to the error constructor
pure subroutine state_parse_arguments(new_state,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
!> The current state variable
class(state_type), intent(inout) :: new_state
!> Input error flag
integer,intent(in) :: flag
!> Optional rank-agnostic arguments
class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, &
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
! Init object
call new_state%destroy()
!> Set error flag
new_state%state = flag
!> Set chain
new_state%message = ""
call appendr(new_state%message,a1)
call appendr(new_state%message,a2)
call appendr(new_state%message,a3)
call appendr(new_state%message,a4)
call appendr(new_state%message,a5)
call appendr(new_state%message,a6)
call appendr(new_state%message,a7)
call appendr(new_state%message,a8)
call appendr(new_state%message,a9)
call appendr(new_state%message,a10)
call appendr(new_state%message,a11)
call appendr(new_state%message,a12)
call appendr(new_state%message,a13)
call appendr(new_state%message,a14)
call appendr(new_state%message,a15)
call appendr(new_state%message,a16)
call appendr(new_state%message,a17)
call appendr(new_state%message,a18)
call appendr(new_state%message,a19)
call appendr(new_state%message,a20)
end subroutine state_parse_arguments
end module stdlib_error
fortran-lang-stdlib-0ede301/src/core/f18estop.f90 0000664 0001750 0001750 00000001172 15135654166 021677 0 ustar alastair alastair submodule (stdlib_error) f18estop
implicit none
contains
module procedure error_stop
! Aborts the program with nonzero exit code
!
! The "stop " statement generally has return code 0.
! To allow non-zero return code termination with character message,
! error_stop() uses the statement "error stop", which by default
! has exit code 1 and prints the message to stderr.
! An optional integer return code "code" may be specified.
!
! Example
! -------
!
! call error_stop("Invalid argument")
if(present(code)) then
write(stderr,*) msg
error stop code
else
error stop msg
endif
end procedure
end submodule f18estop
fortran-lang-stdlib-0ede301/src/core/stdlib_optval.fypp 0000664 0001750 0001750 00000003414 15135654166 023455 0 ustar alastair alastair #:include "common.fypp"
#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES + &
& [('l1','logical')]
module stdlib_optval
!!
!! Provides a generic function `optval`, which can be used to
!! conveniently implement fallback values for optional arguments
!! to subprograms
!! ([Specification](../page/specs/stdlib_optval.html))
!!
!! If `x` is an `optional` parameter of a
!! subprogram, then the expression `optval(x, default)` inside that
!! subprogram evaluates to `x` if it is present, otherwise `default`.
!!
!! It is an error to call `optval` with a single actual argument.
!!
use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64
implicit none
private
public :: optval
interface optval
!! version: experimental
!!
!! Fallback value for optional arguments
!! ([Specification](../page/specs/stdlib_optval.html#description))
#:for k1, t1 in KINDS_TYPES
module procedure optval_${t1[0]}$${k1}$
#:endfor
module procedure optval_character
! TODO: differentiate ascii & ucs char kinds
end interface optval
contains
#:for k1, t1 in KINDS_TYPES
pure elemental function optval_${t1[0]}$${k1}$(x, default) result(y)
${t1}$, intent(in), optional :: x
${t1}$, intent(in) :: default
${t1}$ :: y
if (present(x)) then
y = x
else
y = default
end if
end function optval_${t1[0]}$${k1}$
#:endfor
! Cannot be made elemental
pure function optval_character(x, default) result(y)
character(len=*), intent(in), optional :: x
character(len=*), intent(in) :: default
character(len=:), allocatable :: y
if (present(x)) then
y = x
else
y = default
end if
end function optval_character
end module stdlib_optval
fortran-lang-stdlib-0ede301/src/core/CMakeLists.txt 0000664 0001750 0001750 00000000516 15135654166 022447 0 ustar alastair alastair set(core_fppFiles
stdlib_ascii.fypp
stdlib_error.fypp
stdlib_kinds.fypp
stdlib_optval.fypp
)
set(core_cppFiles
)
set(core_f90Files
$,f18estop.f90,f08estop.f90>
stdlib_io_aux.f90
)
configure_stdlib_target(${PROJECT_NAME}_core core_f90Files core_fppFiles core_cppFiles)
fortran-lang-stdlib-0ede301/src/core/f08estop.f90 0000664 0001750 0001750 00000001604 15135654166 021676 0 ustar alastair alastair submodule (stdlib_error) f08estop
implicit none
contains
module procedure error_stop
! Aborts the program with nonzero exit code
! this is a fallback for Fortran 2008 error stop (e.g. Intel 19.1/2020 compiler)
!
! The "stop " statement generally has return code 0.
! To allow non-zero return code termination with character message,
! error_stop() uses the statement "error stop", which by default
! has exit code 1 and prints the message to stderr.
! An optional integer return code "code" may be specified.
!
! Example
! -------
!
! call error_stop("Invalid argument")
write(stderr,*) msg
if(present(code)) then
select case (code)
case (1)
error stop 1
case (2)
error stop 2
case (77)
error stop 77
case default
write(stderr,*) 'ERROR: code ',code,' was specified.'
error stop
end select
else
error stop
endif
end procedure
end submodule f08estop
fortran-lang-stdlib-0ede301/src/core/stdlib_ascii.fypp 0000664 0001750 0001750 00000034765 15135654166 023255 0 ustar alastair alastair #:include "common.fypp"
!> The `stdlib_ascii` module provides procedures for handling and manipulating
!> intrinsic character variables and constants.
!>
!> The specification of this module is available [here](../page/specs/stdlib_ascii.html).
module stdlib_ascii
use stdlib_kinds, only : int8, int16, int32, int64, lk, c_bool
implicit none
private
! Character validation functions
public :: is_alpha, is_alphanum
public :: is_digit, is_hex_digit, is_octal_digit
public :: is_control, is_white, is_blank
public :: is_ascii, is_punctuation
public :: is_graphical, is_printable
public :: is_lower, is_upper
! Character conversion functions
public :: to_lower, to_upper, to_title, to_sentence, reverse
! All control characters in the ASCII table (see www.asciitable.com).
character(len=1), public, parameter :: NUL = achar(int(z'00')) !! Null
character(len=1), public, parameter :: SOH = achar(int(z'01')) !! Start of heading
character(len=1), public, parameter :: STX = achar(int(z'02')) !! Start of text
character(len=1), public, parameter :: ETX = achar(int(z'03')) !! End of text
character(len=1), public, parameter :: EOT = achar(int(z'04')) !! End of transmission
character(len=1), public, parameter :: ENQ = achar(int(z'05')) !! Enquiry
character(len=1), public, parameter :: ACK = achar(int(z'06')) !! Acknowledge
character(len=1), public, parameter :: BEL = achar(int(z'07')) !! Bell
character(len=1), public, parameter :: BS = achar(int(z'08')) !! Backspace
character(len=1), public, parameter :: TAB = achar(int(z'09')) !! Horizontal tab
character(len=1), public, parameter :: LF = achar(int(z'0A')) !! NL line feed, new line
character(len=1), public, parameter :: VT = achar(int(z'0B')) !! Vertical tab
character(len=1), public, parameter :: FF = achar(int(z'0C')) !! NP form feed, new page
character(len=1), public, parameter :: CR = achar(int(z'0D')) !! Carriage return
character(len=1), public, parameter :: SO = achar(int(z'0E')) !! Shift out
character(len=1), public, parameter :: SI = achar(int(z'0F')) !! Shift in
character(len=1), public, parameter :: DLE = achar(int(z'10')) !! Data link escape
character(len=1), public, parameter :: DC1 = achar(int(z'11')) !! Device control 1
character(len=1), public, parameter :: DC2 = achar(int(z'12')) !! Device control 2
character(len=1), public, parameter :: DC3 = achar(int(z'13')) !! Device control 3
character(len=1), public, parameter :: DC4 = achar(int(z'14')) !! Device control 4
character(len=1), public, parameter :: NAK = achar(int(z'15')) !! Negative acknowledge
character(len=1), public, parameter :: SYN = achar(int(z'16')) !! Synchronous idle
character(len=1), public, parameter :: ETB = achar(int(z'17')) !! End of transmission block
character(len=1), public, parameter :: CAN = achar(int(z'18')) !! Cancel
character(len=1), public, parameter :: EM = achar(int(z'19')) !! End of medium
character(len=1), public, parameter :: SUB = achar(int(z'1A')) !! Substitute
character(len=1), public, parameter :: ESC = achar(int(z'1B')) !! Escape
character(len=1), public, parameter :: FS = achar(int(z'1C')) !! File separator
character(len=1), public, parameter :: GS = achar(int(z'1D')) !! Group separator
character(len=1), public, parameter :: RS = achar(int(z'1E')) !! Record separator
character(len=1), public, parameter :: US = achar(int(z'1F')) !! Unit separator
character(len=1), public, parameter :: DEL = achar(int(z'7F')) !! Delete
! Constant character sequences
character(len=*), public, parameter :: fullhex_digits = "0123456789ABCDEFabcdef" !! 0 .. 9A .. Fa .. f
character(len=*), public, parameter :: hex_digits = fullhex_digits(1:16) !! 0 .. 9A .. F
character(len=*), public, parameter :: lowerhex_digits = "0123456789abcdef" !! 0 .. 9a .. f
character(len=*), public, parameter :: digits = hex_digits(1:10) !! 0 .. 9
character(len=*), public, parameter :: octal_digits = digits(1:8) !! 0 .. 7
character(len=*), public, parameter :: letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" !! A .. Za .. z
character(len=*), public, parameter :: uppercase = letters(1:26) !! A .. Z
character(len=*), public, parameter :: lowercase = letters(27:) !! a .. z
character(len=*), public, parameter :: whitespace = " "//TAB//VT//CR//LF//FF !! ASCII _whitespace
!> Returns a new character sequence which is the lower case
!> version of the input character sequence
!> This method is elemental and returns a character sequence
interface to_lower
module procedure :: to_lower
end interface to_lower
!> Returns a new character sequence which is the upper case
!> version of the input character sequence
!> This method is elemental and returns a character sequence
interface to_upper
module procedure :: to_upper
end interface to_upper
!> Returns a new character sequence which is the title case
!> version of the input character sequence
!> This method is elemental and returns a character sequence
interface to_title
module procedure :: to_title
end interface to_title
!> Returns a new character sequence which is the sentence case
!> version of the input character sequence
!> This method is elemental and returns a character sequence
interface to_sentence
module procedure :: to_sentence
end interface to_sentence
!> Returns a new character sequence which is reverse of
!> the input charater sequence
!> This method is elemental and returns a character sequence
interface reverse
module procedure :: reverse
end interface reverse
contains
!> Checks whether `c` is an ASCII letter (A .. Z, a .. z).
elemental logical function is_alpha(c)
character(len=1), intent(in) :: c !! The character to test.
is_alpha = (c >= 'A' .and. c <= 'Z') .or. (c >= 'a' .and. c <= 'z')
end function
!> Checks whether `c` is a letter or a number (0 .. 9, a .. z, A .. Z).
elemental logical function is_alphanum(c)
character(len=1), intent(in) :: c !! The character to test.
is_alphanum = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'z') &
.or. (c >= 'A' .and. c <= 'Z')
end function
!> Checks whether or not `c` is in the ASCII character set -
!> i.e. in the range 0 .. 0x7F.
elemental logical function is_ascii(c)
character(len=1), intent(in) :: c !! The character to test.
is_ascii = iachar(c) <= int(z'7F')
end function
!> Checks whether `c` is a control character.
elemental logical function is_control(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c)
is_control = ic < int(z'20') .or. ic == int(z'7F')
end function
!> Checks whether `c` is a digit (0 .. 9).
elemental logical function is_digit(c)
character(len=1), intent(in) :: c !! The character to test.
is_digit = ('0' <= c) .and. (c <= '9')
end function
!> Checks whether `c` is a digit in base 8 (0 .. 7).
elemental logical function is_octal_digit(c)
character(len=1), intent(in) :: c !! The character to test.
is_octal_digit = (c >= '0') .and. (c <= '7');
end function
!> Checks whether `c` is a digit in base 16 (0 .. 9, A .. F, a .. f).
elemental logical function is_hex_digit(c)
character(len=1), intent(in) :: c !! The character to test.
is_hex_digit = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'f') &
.or. (c >= 'A' .and. c <= 'F')
end function
!> Checks whether or not `c` is a punctuation character. That includes
!> all ASCII characters which are not control characters, letters,
!> digits, or whitespace.
elemental logical function is_punctuation(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c) ! '~' '!'
is_punctuation = (ic <= int(z'7E')) .and. (ic >= int(z'21')) .and. &
(.not. is_alphanum(c))
end function
!> Checks whether or not `c` is a printable character other than the
!> space character.
elemental logical function is_graphical(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c)
!The character is graphical if it's between '!' and '~' in the ASCII table,
!that is: printable but not a space
is_graphical = (int(z'21') <= ic) .and. (ic <= int(z'7E'))
end function
!> Checks whether or not `c` is a printable character - including the
!> space character.
elemental logical function is_printable(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c)
!The character is printable if it's between ' ' and '~' in the ASCII table
is_printable = ic >= iachar(' ') .and. ic <= int(z'7E')
end function
!> Checks whether `c` is a lowercase ASCII letter (a .. z).
elemental logical function is_lower(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c)
is_lower = ic >= iachar('a') .and. ic <= iachar('z')
end function
!> Checks whether `c` is an uppercase ASCII letter (A .. Z).
elemental logical function is_upper(c)
character(len=1), intent(in) :: c !! The character to test.
is_upper = (c >= 'A') .and. (c <= 'Z')
end function
!> Checks whether or not `c` is a whitespace character. That includes the
!> space, tab, vertical tab, form feed, carriage return, and linefeed
!> characters.
elemental logical function is_white(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c) ! TAB, LF, VT, FF, CR
is_white = (c == ' ') .or. (ic >= int(z'09') .and. ic <= int(z'0D'));
end function
!> Checks whether or not `c` is a blank character. That includes the
!> only the space and tab characters
elemental logical function is_blank(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c) ! TAB
is_blank = (c == ' ') .or. (ic == int(z'09'));
end function
!> Returns the corresponding lowercase letter, if `c` is an uppercase
!> ASCII character, otherwise `c` itself.
elemental function char_to_lower(c) result(t)
character(len=1), intent(in) :: c !! A character.
character(len=1) :: t
integer, parameter :: wp= iachar('a')-iachar('A'), BA=iachar('A'), BZ=iachar('Z')
integer :: k
!Check whether the integer equivalent is between BA=65 and BZ=90
k = ichar(c)
if (k>=BA.and.k<=BZ) k = k + wp
t = char(k)
end function char_to_lower
!> Returns the corresponding uppercase letter, if `c` is a lowercase
!> ASCII character, otherwise `c` itself.
elemental function char_to_upper(c) result(t)
character(len=1), intent(in) :: c !! A character.
character(len=1) :: t
integer, parameter :: wp= iachar('a')-iachar('A'), la=iachar('a'), lz=iachar('z')
integer :: k
!Check whether the integer equivalent is between la=97 and lz=122
k = ichar(c)
if (k>=la.and.k<=lz) k = k - wp
t = char(k)
end function char_to_upper
!> Convert character variable to lower case
!> ([Specification](../page/specs/stdlib_ascii.html#to_lower))
!>
!> Version: experimental
elemental function to_lower(string) result(lower_string)
character(len=*), intent(in) :: string
character(len=len(string)) :: lower_string
integer :: i
do i = 1, len(string)
lower_string(i:i) = char_to_lower(string(i:i))
end do
end function to_lower
!> Convert character variable to upper case
!> ([Specification](../page/specs/stdlib_ascii.html#to_upper))
!>
!> Version: experimental
elemental function to_upper(string) result(upper_string)
character(len=*), intent(in) :: string
character(len=len(string)) :: upper_string
integer :: i
do i = 1, len(string)
upper_string(i:i) = char_to_upper(string(i:i))
end do
end function to_upper
!> Converts character sequence to title case
!> ([Specification](../page/specs/stdlib_ascii.html#to_title))
!>
!> Version: experimental
elemental function to_title(string) result(title_string)
character(len=*), intent(in) :: string
character(len=len(string)) :: title_string
integer :: i
logical :: capitalize_switch
capitalize_switch = .true.
do i = 1, len(string)
if (is_alphanum(string(i:i))) then
if (capitalize_switch) then
title_string(i:i) = char_to_upper(string(i:i))
capitalize_switch = .false.
else
title_string(i:i) = char_to_lower(string(i:i))
end if
else
title_string(i:i) = string(i:i)
capitalize_switch = .true.
end if
end do
end function to_title
!> Converts character sequence to sentence case
!> ([Specification](../page/specs/stdlib_ascii.html#to_sentence))
!>
!> Version: experimental
elemental function to_sentence(string) result(sentence_string)
character(len=*), intent(in) :: string
character(len=len(string)) :: sentence_string
integer :: i, n
n = len(string)
do i = 1, len(string)
if (is_alphanum(string(i:i))) then
sentence_string(i:i) = char_to_upper(string(i:i))
n = i
exit
else
sentence_string(i:i) = string(i:i)
end if
end do
do i = n + 1, len(string)
sentence_string(i:i) = char_to_lower(string(i:i))
end do
end function to_sentence
!> Reverse the character order in the input character variable
!> ([Specification](../page/specs/stdlib_ascii.html#reverse))
!>
!> Version: experimental
elemental function reverse(string) result(reverse_string)
character(len=*), intent(in) :: string
character(len=len(string)) :: reverse_string
integer :: i, n
n = len(string)
do i = 1, n
reverse_string(n-i+1:n-i+1) = string(i:i)
end do
end function reverse
end module stdlib_ascii
fortran-lang-stdlib-0ede301/src/core/stdlib_kinds.fypp 0000664 0001750 0001750 00000001577 15135654166 023270 0 ustar alastair alastair #:include "common.fypp"
!> Version: experimental
!>
!> The specification of this module is available [here](../page/specs/stdlib_kinds.html).
module stdlib_kinds
use iso_fortran_env, only: int8, int16, int32, int64
use iso_c_binding, only: c_bool, c_char
implicit none
private
public :: sp, dp, xdp, qp, int8, int16, int32, int64, lk, c_bool, c_char
!> Single precision real numbers
integer, parameter :: sp = selected_real_kind(6)
!> Double precision real numbers
integer, parameter :: dp = selected_real_kind(15)
!> Extended double precision real numbers
integer, parameter :: xdp = #{if WITH_XDP}#selected_real_kind(18)#{else}#-1#{endif}#
!> Quadruple precision real numbers
integer, parameter :: qp = #{if WITH_QP}#selected_real_kind(33)#{else}#-1#{endif}#
!> Default logical kind parameter
integer, parameter :: lk = kind(.true.)
end module stdlib_kinds
fortran-lang-stdlib-0ede301/src/hashmaps/ 0000775 0001750 0001750 00000000000 15135654166 020561 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/hashmaps/stdlib_hashmap_open.f90 0000664 0001750 0001750 00000102410 15135654166 025102 0 ustar alastair alastair !! The module, STDLIB_HASHMAP_OPEN implements a simple open addressing hash
!! map using linear addressing. The implementation is loosely based on a
!! C implementation by David Chase, http://chasewoerner.org/src/hasht/, for
!! which he has given permission to use in the Fortran Standard Library.
! Note an error in the code caused attempts to deallocate already deallocated
! entries. This did not cause stat to be non-zero, but did cause system errors,
! on my Mac. I therefore decided to remove all deallocation error reporting.
submodule(stdlib_hashmaps) stdlib_hashmap_open
use, intrinsic :: iso_fortran_env, only: &
character_storage_size, &
error_unit
use stdlib_hashmap_wrappers
implicit none
! Error messages
character(len=*), parameter :: &
alloc_inv_fault = "OPEN_HASHMAP_TYPE % INVERSE allocation fault.", &
alloc_key_fault = "KEY allocation fault.", &
alloc_slots_fault = "OPEN_HASHMAP_TYPE % SLOTS allocation fault.", &
conflicting_key = "KEY already exists in MAP.", &
expand_slots_fail = "OPEN_HASHMAP_TYPE % SLOTS allocation > " // &
"MAX_BITS.", &
init_slots_pow_fail = "SLOTS_BITS is not between DEFAULT_BITS " // &
"and MAX_BITS.", &
invalid_inmap = "INMAP was not a valid INVERSE index.", &
map_consist_fault = "The hash map found an inconsistency."
character(*), parameter :: submodule_name = 'STDLIB_HASHMAP_OPEN'
interface expand_slots
!! Version: Experimental
!!
!! Interface to internal procedure that expands an open map's slots.
module procedure expand_open_slots
end interface expand_slots
interface extend_map_entry_pool
!! Version: Experimental
!!
!! Interface to internal procedure that expands an open map entry pool.
module procedure extend_open_map_entry_pool
end interface extend_map_entry_pool
interface free_map
!! Version: Experimental
!!
!! Interface to procedure that finalizes an open hash map.
module procedure free_open_map
end interface free_map
interface free_map_entry_pool
!! Version: Experimental
!!
!! Interface to internal procedure that finalizes an open hash map
!! entry pool.
module procedure free_map_entry_pool
end interface free_map_entry_pool
interface get_other_data
!! Version: Experimental
!!
!! Interface to procedure that gets an entry's other data.
module procedure get_other_open_data
end interface get_other_data
interface init
!! Version: Experimental
!!
!! Interface to initialization procedure for an open hash map.
module procedure init_open_map
end interface init
interface rehash
!! Version: Experimental
!!
!! Interface to a procedure that changes the hash function that
!! is used to map the keys into an open hash map.
module procedure rehash_open_map
end interface rehash
interface remove
!! Version: Experimental
!!
!! Interface to a procedure that removees an entry from an open hash map.
module procedure remove_open_entry
end interface remove
interface set_other_data
!! Version: Experimental
!!
!! Interface to a procedure that changes the other data associated with a key
module procedure set_other_open_data
end interface set_other_data
contains
subroutine expand_open_slots( map )
!! Version: Experimental
!!
!! Internal routine to make a duplicate map with more hash slots.
!! Doubles the size of the map % slots array
!! Arguments:
!! map - the hash table whose hash slots are to be expanded
!
type(open_hashmap_type), intent(inout) :: map
integer(int_hash) :: base_slot
integer(int_index), allocatable :: dummy_slots(:)
integer(int_index) :: inv_index, &
new_size, &
offset, &
old_size, &
test_slot
integer(int32) :: bits, &
stat
character(256) :: errmsg
character(*), parameter :: procedure = 'EXPAND_SLOTS'
if ( map % nbits == max_bits ) then
error stop submodule_name // ' % ' // procedure // ': ' // &
expand_slots_fail
end if
old_size = size(map % slots, kind=int_index)
new_size = 2*old_size
bits = map % nbits + 1
allocate( dummy_slots(0:new_size-1), stat=stat, errmsg=errmsg )
if (stat /= 0) then
error stop submodule_name // ' % ' // procedure // ': ' // &
alloc_slots_fault
end if
map % nbits = bits
dummy_slots(:) = 0
map % index_mask = new_size-1
map % total_probes = map % total_probes + map % probe_count
map % probe_count = 0
REMAP_SLOTS: do inv_index=1_int_index, &
map % num_entries + map % num_free
associate( inverse => map % inverse(inv_index) )
if ( associated(inverse % target) ) then
base_slot = fibonacci_hash( inverse % target % hash_val, &
map % nbits )
offset = 0
FIND_EMPTY_SLOT: do
test_slot = iand( int( base_slot + offset, int_hash), &
map % index_mask )
if ( dummy_slots(test_slot) == 0 ) then
dummy_slots(test_slot) = inv_index
exit FIND_EMPTY_SLOT
end if
offset = offset + 1
end do FIND_EMPTY_SLOT
end if
end associate
end do REMAP_SLOTS
call move_alloc( dummy_slots, map % slots )
end subroutine expand_open_slots
subroutine extend_open_map_entry_pool(pool) ! gent_pool_new
!! Version: Experimental
!!
!! Add more map_entrys to the pool head
!! Arguments:
!! pool - an open map entry pool
type(open_map_entry_pool), intent(inout), pointer :: pool
type(open_map_entry_pool), pointer :: map_entry_pool_head
allocate(map_entry_pool_head)
allocate(map_entry_pool_head % more_map_entries(0:pool_size-1))
map_entry_pool_head % lastpool => pool
pool => map_entry_pool_head
pool % next = 0
end subroutine extend_open_map_entry_pool
recursive subroutine free_map_entry_pool(pool) ! gent_pool_free
!! Version: Experimental
!! Note the freeing of allocated memory may be unnecessary
!!
!! Recursively descends map entry pool list freeing each element
!! Arguments:
!! pool The map entry pool whose elements are to be freed
!
type(open_map_entry_pool), intent(inout), pointer :: pool
type(open_map_entry_pool), pointer :: lastpool
if ( associated(pool) ) then
lastpool => pool % lastpool
pool % lastpool => null()
deallocate( pool )
! Trace component pointers/lists
call free_map_entry_pool( lastpool )
end if
end subroutine free_map_entry_pool
module subroutine free_open_map( map )
!! Version: Experimental
!!
!! Frees internal memory of an open map
!! Arguments:
!! map - the open hash map whose memory is to be freed
!
type(open_hashmap_type), intent(inout) :: map
type(open_map_entry_list), pointer :: free_list
integer(int_index) :: i
if ( allocated( map % slots ) ) then
deallocate( map % slots )
end if
if ( allocated( map % inverse ) ) then
remove_links: do i=1, size( map % inverse, kind=int_index )
map % inverse(i) % target => null()
end do remove_links
deallocate( map % inverse )
end if
free_free_list: do while( map % num_free > 0 )
free_list => map % free_list
map % free_list => map % free_list % next
free_list % next => null()
free_list % target => null()
map % num_free = map % num_free - 1
end do free_free_list
map % num_free = 0
if ( associated( map % cache ) ) call free_map_entry_pool(map % cache)
map % num_entries = 0
end subroutine free_open_map
module subroutine get_all_open_keys(map, all_keys)
!! Version: Experimental
!!
!! Returns all the keys contained in a hash map
!! Arguments:
!! map - an open hash map
!! all_keys - all the keys contained in a hash map
!
class(open_hashmap_type), intent(in) :: map
type(key_type), allocatable, intent(out) :: all_keys(:)
integer(int32) :: num_keys
integer(int_index) :: i, key_idx
num_keys = map % entries()
allocate( all_keys(num_keys) )
if ( num_keys == 0 ) return
if ( allocated( map % inverse) ) then
key_idx = 1_int_index
do i=1_int_index, size( map % inverse, kind=int_index )
if ( associated( map % inverse(i) % target ) ) then
all_keys(key_idx) = map % inverse(i) % target % key
key_idx = key_idx + 1_int_index
end if
end do
end if
end subroutine get_all_open_keys
module subroutine get_other_open_data( map, key, other, exists )
!! Version: Experimental
!!
!! Returns the other data associated with the inverse table index
!! Arguments:
!! map - an open hash table
!! key - the key associated with a map entry
!! other - the other data associated with the key
!! exists - a logical flag indicating whether an entry with that key exists
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), allocatable, intent(out) :: other
logical, intent(out), optional :: exists
integer(int_index) :: inmap
character(*), parameter :: procedure = 'GET_OTHER_DATA'
call in_open_map(map, inmap, key)
if ( inmap <= 0 .or. &
inmap > map % num_entries + map % num_free ) then
if ( present(exists) ) then
exists = .false.
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
invalid_inmap
end if
else if ( associated( map % inverse(inmap) % target ) ) then
if ( present(exists) ) exists = .true.
other = map % inverse(inmap) % target % other
else
if ( present(exists) ) then
exists = .false.
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
map_consist_fault
end if
end if
end subroutine get_other_open_data
subroutine in_open_map(map, inmap, key) ! Chase's inmap
!! Version: Experimental
!!
!! Returns the index into the INVERSE array associated with the KEY
!! Arguments:
!! map - the hash map of interest
!! inmap - the returned index into the INVERSE array of entry pointers
!! key - the key identifying the entry of interest
!
class(open_hashmap_type), intent(inout) :: map
integer(int_index), intent(out) :: inmap
type(key_type), intent(in) :: key
character(*), parameter :: procedure = 'IN_MAP'
integer(int_hash) :: &
base_slot, &
hash_val, &
test_slot
integer(int_index) :: &
offset
hash_val = map % hasher( key )
if ( map % probe_count > inmap_probe_factor * map % call_count .or. &
map % num_entries >= load_factor * &
size( map % slots, kind=int_index ) ) then
if ( map % nbits < max_bits ) &
call expand_slots(map)
end if
map % call_count = map % call_count + 1
base_slot = fibonacci_hash( hash_val, map % nbits )
offset = 0_int_index
PROBE_SLOTS: do
test_slot = iand( base_slot + offset, map % index_mask )
map % probe_count = map % probe_count + 1
inmap = map % slots( test_slot )
if ( inmap == 0 ) then
return
else if ( inmap < 0 .or. &
inmap > map % num_entries + map % num_free ) then
error stop submodule_name // ' % ' // procedure // ': ' // &
map_consist_fault
else if ( .not. associated( map % inverse(inmap) % target ) ) then
error stop submodule_name // ' % ' // procedure // ': ' // &
map_consist_fault
else
associate( inverse => map % inverse(inmap) )
if ( hash_val == inverse % target % hash_val ) then
if ( key == inverse % target % key ) then
return
end if
end if
end associate
end if
offset = offset + 1_int_index
end do PROBE_SLOTS
end subroutine in_open_map
module subroutine init_open_map( map, &
hasher, &
slots_bits, &
status )
!! Version: Experimental
!!
!! Routine to allocate an empty map with HASHER as the hash function,
!! 2**SLOTS_BITS initial SIZE(map % slots), and SIZE(map % slots) limited to a
!! maximum of 2**MAX_BITS. All fields are initialized.
!! Arguments:
!! map - the open hash maap to be initialized
!! hasher - the hash function to be used to map keys to slots
!! slots_bits - the number of bits used to map to the slots
!! status - an integer error status flag with the allowed values:
!! success - no problems were found
!! alloc_fault - map % slots or map % inverse could not be allocated
!! array_size_error - slots_bits is less than default_bitd or
!! greater than max_bits
class(open_hashmap_type), intent(out) :: map
procedure(hasher_fun), optional :: hasher
integer, intent(in), optional :: slots_bits
integer(int32), intent(out), optional :: status
character(256) :: errmsg
integer(int_index) :: i
character(*), parameter :: procedure = 'INIT'
integer(int_index) :: slots
integer(int32) :: stat
type(open_map_entry_pool), pointer :: map_entry_pool_head
map % call_count = 0
map % probe_count = 0
map % total_probes = 0
! Check if user has specified a hasher other than the default hasher.
if (present(hasher)) map % hasher => hasher
if ( present(slots_bits) ) then
if ( slots_bits < default_bits .OR. &
slots_bits > max_bits ) then
if ( present(status) ) then
status = array_size_error
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
init_slots_pow_fail
end if
end if
map % nbits = slots_bits
else
map % nbits = min( default_bits, max_bits )
end if
slots = 2_int32**map % nbits
map % index_mask = slots - 1
allocate( map % slots(0:slots-1), stat=stat, errmsg=errmsg )
if ( stat /= 0 ) then
if ( present(status) ) then
status = alloc_fault
return
else
write(error_unit, '(a)') 'Allocation ERRMSG: ' // trim(errmsg)
error stop submodule_name // ' % ' // procedure // ': ' // &
alloc_slots_fault
end if
end if
do i=0, size( map % slots, kind=int_index ) - 1
map % slots(i) = 0 ! May be redundant
end do
!! 5*s from Chase's g_new_map
allocate( map % inverse(1:ceiling(load_factor*slots, &
kind=int_index)), &
stat=stat, &
errmsg=errmsg )
if ( stat /= 0 ) then
if ( present( status ) ) then
status = alloc_fault
return
else
write(error_unit, '(a)') 'Allocation ERRMSG: ' // trim(errmsg)
error stop submodule_name // ' % ' // procedure // ': ' // &
alloc_inv_fault
end if
end if
do i=1, size(map % inverse, kind=int_index)
map % inverse(i) % target => null()
end do
do while(associated(map % cache))
map_entry_pool_head => map % cache
map % cache => map_entry_pool_head % lastpool
map_entry_pool_head % lastpool => null()
deallocate( map_entry_pool_head % more_map_entries )
deallocate( map_entry_pool_head )
end do
call extend_map_entry_pool(map % cache)
map % initialized = .true.
if (present(status) ) status = success
end subroutine init_open_map
pure module function open_loading( map )
!! Version: Experimental
!!
!! Returns the number of entries relative to slots in a hash map
!! Arguments:
!! map - an open hash map
class(open_hashmap_type), intent(in) :: map
real :: open_loading
open_loading = real( map % num_entries ) / &
size( map % slots, kind=int_index )
end function open_loading
module subroutine map_open_entry(map, key, other, conflict)
!! Version: Experimental
!!
!! Inserts an entry into the hash table
!! Arguments:
!! map the hash table of interest
!! key - the key identifying the entry
!! other - other data associated with the key
!! conflict - logical flag indicating whether the entry key conflicts
!! with an existing key
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in), optional :: other
logical, intent(out), optional :: conflict
type(open_map_entry_type), pointer :: new_ent
integer(int_hash) :: base_slot
integer(int_hash) :: hash_val
integer(int_index) :: inmap, offset, test_slot
character(*), parameter :: procedure = 'MAP_ENTRY'
! Check that map is initialized.
if (.not. map % initialized) call init_open_map( map )
hash_val = map % hasher( key )
if ( map % probe_count > map_probe_factor * map % call_count .or. &
map % num_entries >= load_factor * size( map % slots, &
kind=int_index) ) then
call expand_slots(map)
end if
map % call_count = map % call_count + 1
base_slot = fibonacci_hash( hash_val, map % nbits )
offset = 0
PROBE_SUCCESSIVE_SLOTS: do
map % probe_count = map % probe_count + 1
test_slot = iand( base_slot + offset, map % index_mask )
inmap = map % slots(test_slot)
if ( inmap == 0 ) then
call allocate_open_map_entry(map, new_ent)
new_ent % hash_val = hash_val
call copy_key( key, new_ent % key )
if ( present( other ) ) new_ent % other = other
inmap = new_ent % inmap
map % inverse( inmap ) % target => new_ent
map % slots( test_slot ) = inmap
if ( present(conflict) ) conflict = .false.
return
else if ( inmap < 0 .or. &
inmap > map % num_entries + map % num_free ) then
error stop submodule_name // ' % ' // procedure // ': ' // &
invalid_inmap
else if (.not. associated( map % inverse(inmap) % target ) ) then
error stop submodule_name // ' % ' // procedure // ': ' // &
invalid_inmap
else
associate( target => map % inverse(inmap) % target )
if ( hash_val == target % hash_val ) then
if ( key == target % key ) then
! entry already exists
if ( present(conflict) ) then
conflict = .true.
else
error stop submodule_name // ' % ' // procedure &
// ': ' // conflicting_key
end if
return
end if
end if
end associate
end if
offset = offset + 1
end do PROBE_SUCCESSIVE_SLOTS
contains
subroutine allocate_open_map_entry(map, bucket)
! allocates a hash bucket
type(open_hashmap_type), intent(inout) :: map
type(open_map_entry_type), pointer, intent(out) :: bucket
type(open_map_entry_list), pointer :: free_list
type(open_map_entry_pool), pointer :: pool
character(*), parameter :: procedure_name = "ALLOCATE_MAP_ENTRY"
pool => map % cache
map % num_entries = map % num_entries + 1
if ( associated(map % free_list) ) then
! Get hash bucket from free_list
free_list => map % free_list
bucket => free_list % target
map % free_list => free_list % next
free_list % target => null()
free_list % next => null()
if (bucket % inmap <= 0) &
error stop submodule_name // " % " // procedure_name // &
": Failed consistency check: BUCKET % INMAP <= 0"
map % num_free = map % num_free - 1
else
! Get hash bucket from pool
if ( pool % next == pool_size ) then
! Expand pool
call extend_map_entry_pool(map % cache)
pool => map % cache
end if
bucket => pool % more_map_entries(pool % next)
pool % next = pool % next + 1 ! 0s based -> post-increment
if ( map % num_entries > &
size( map % inverse, kind=int_index ) ) then
call expand_inverse( map )
end if
if ( map % num_entries <= 0 ) &
error stop submodule_name // " % " // procedure_name // &
": Failed consistency check: MAP % NUM_ENTRIES <= 0."
bucket % inmap = map % num_entries
end if
end subroutine allocate_open_map_entry
subroutine expand_inverse(map)
!! Increase size of map % inverse
type(open_hashmap_type), intent(inout) :: map
type(open_map_entry_ptr), allocatable :: dummy_inverse(:)
integer(int32) :: stat
character(256) :: errmsg
allocate( dummy_inverse(1:2*size(map % inverse, kind=int_index)), &
stat=stat, errmsg=errmsg )
if ( stat /= 0 ) then
write(error_unit, '(a)') 'Allocation ERRMSG: ' // trim(errmsg)
error stop submodule_name // ' % ' // procedure // ': ' // &
alloc_inv_fault
end if
dummy_inverse(1:size(map % inverse, kind=int_index)) = &
map % inverse(:)
call move_alloc( dummy_inverse, map % inverse )
end subroutine expand_inverse
end subroutine map_open_entry
module subroutine rehash_open_map( map, hasher )
!! Version: Experimental
!!
!! Changes the hashing method of the table entries to that of HASHER.
!! Arguments:
!! map the table to be rehashed
!! hasher the hasher function to be used for the table
!
class(open_hashmap_type), intent(inout) :: map
procedure(hasher_fun) :: hasher
integer(int_hash) :: base_slot
integer(int_hash) :: hash_val
integer(int_index) :: i, test_slot, offset
map % hasher => hasher
map % slots = 0
do i=1, map % num_entries + map % num_free
if ( .not. associated( map % inverse(i) % target ) ) cycle
hash_val = map % hasher( map % inverse(i) % target % key )
map % inverse(i) % target % hash_val = hash_val
base_slot = fibonaccI_hash( hash_val, map % nbits )
offset = 0
FIND_EMPTY_SLOT: do
test_slot = iand( int( base_slot + offset, int_hash ), &
map % index_mask )
if ( map % slots(test_slot) == 0 ) then
map % slots(test_slot) = i
exit FIND_EMPTY_SLOT
end if
offset = offset + 1
end do FIND_EMPTY_SLOT
end do
end subroutine rehash_open_map
module subroutine remove_open_entry(map, key, existed)
!! Remove the entry, if any, that has the key
!! Arguments:
!! map - the table from which the entry is to be removed
!! key - the key to an entry
!! existed - a logical flag indicating whether an entry with the key
!! was present in the original map
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out), optional :: existed
type(open_map_entry_list), pointer :: aentry
type(open_map_entry_type), pointer :: bucket
integer(int_index) :: base_slot
integer(int_index) :: current_index
integer(int_index) :: current_slot
integer(int_index) :: empty_slot
integer(int_index) :: inmap
logical :: overlap
integer(int_index) :: slot_index
overlap = .false.
call in_open_map( map, inmap, key )
if ( inmap < 1 .or. inmap > size( map % inverse ) ) then
if ( present( existed ) ) existed = .false.
return
end if
bucket => map % inverse(inmap) % target
if ( associated(bucket) ) then
base_slot = fibonacci_hash( bucket % hash_val, map % nbits )
if ( present(existed) ) existed = .true.
else
if ( present( existed ) ) existed = .false.
return
end if
! Find slot associated with inmap and nullify the pointer
current_slot = base_slot
search_for_inmap: do
slot_index = map % slots(current_slot)
if ( slot_index == inmap ) then
allocate(aentry)
aentry % target => map % inverse(inmap) % target
aentry % next => map % free_list
map % free_list => aentry
map % num_free = map % num_free + 1
map % slots( current_slot ) = 0
map % inverse(inmap) % target => null()
map % num_entries = map % num_entries - 1
empty_slot = current_slot
current_slot = iand( map % index_mask, current_slot + 1 )
if ( map % slots(current_slot) == 0 ) return
if ( current_slot == 0 ) overlap = .true.
exit search_for_inmap
else
if ( map % slots(current_slot) == 0 ) return
current_slot = iand( map % index_mask, current_slot + 1 )
if ( current_slot == 0 ) overlap = .true.
cycle search_for_inmap
end if
end do search_for_inmap
! Have found slot and stored it in free_list, now may need to iteratively
! swap to fill holes. First search backwards to find start of run.
find_run_start: do
base_slot = iand( map % index_mask, base_slot - 1 )
if ( base_slot == map % index_mask ) then
if ( map % slots(base_slot) == 0 ) then
base_slot = 0
exit find_run_start
else
overlap = .true.
cycle find_run_start
end if
else if ( map % slots(base_slot) == 0 ) then
base_slot = iand( map % index_mask, base_slot + 1 )
exit find_run_start
else
cycle find_run_start
end if
end do find_run_start
! Search forward for entry to fill empty slot
fill_empty_slots: do
bucket => map % inverse(map % slots(current_slot) ) % target
current_index = fibonacci_hash( bucket % hash_val, &
map % nbits )
if ( overlap .and. empty_slot < base_slot ) then
if ( ( current_index >= base_slot .and. &
current_index <= map % index_mask ) .or. &
( current_index >= 0 .and. &
current_index <= empty_slot ) ) then
map % slots( empty_slot ) = map % slots( current_slot )
map % slots( current_slot ) = 0
empty_slot = current_slot
end if
current_slot = iand( map % index_mask, current_slot + 1 )
else
if ( current_index >= base_slot .and. &
current_index <= empty_slot ) then
map % slots( empty_slot ) = map % slots( current_slot )
map % slots( current_slot ) = 0
empty_slot = current_slot
end if
current_slot = iand( map % index_mask, current_slot + 1 )
if ( current_slot == 0 ) overlap = .true.
end if
if ( map % slots( current_slot ) == 0 ) exit fill_empty_slots
end do fill_empty_slots
end subroutine remove_open_entry
module subroutine set_other_open_data( map, key, other, exists )
!! Version: Experimental
!!
!! Change the other data associated with the key
!! Arguments:
!! map - the map with the entry of interest
!! key - the key to the entry inthe map
!! other - the new data to be associated with the key
!! exists - a logical flag indicating whether the key is already entered
!! in the map
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in) :: other
logical, intent(out),optional :: exists
integer(int_index) :: inmap
character(*), parameter :: procedure = 'SET_OTHER_DATA'
call in_open_map( map, inmap, key )
if ( inmap <= 0 .or. inmap > size( map % inverse, kind=int_index ) ) &
then
if ( present(exists) ) then
exists = .false.
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
invalid_inmap
end if
else if ( associated( map % inverse(inmap) % target ) ) then
map % inverse(inmap) % target % other = other
if ( present(exists) ) exists = .true.
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
invalid_inmap
end if
end subroutine set_other_open_data
module function total_open_depth( map ) result(total_depth)
!! Version: Experimental
!!
!! Returns the total number of ones based offsets of slot entries from
!! their slot index for a hash map
!! Arguments:
!! map - an open hash map
class(open_hashmap_type), intent(in) :: map
integer(int64) :: total_depth
integer(int_index) :: inv_index, slot, slots
integer(int_hash) :: index
total_depth = 0_int64
slots = size( map % slots, kind=int_index )
do slot=0, slots-1
if ( map % slots( slot ) == 0 ) cycle
inv_index = map % slots( slot )
if ( inv_index <= 0 ) cycle
associate( inverse => map % inverse( inv_index ))
index = fibonacci_hash( inverse % target % hash_val, &
map % nbits )
end associate
total_depth = total_depth + &
iand( slot - index, map % index_mask ) + 1_int64
end do
end function total_open_depth
module subroutine open_key_test(map, key, present)
!! Version: Experimental
!!
!! Returns a logical flag indicating whether KEY exists in the hash map
!! Arguments:
!! map - the hash map of interest
!! key - the key of interest
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out) :: present
integer(int_index) :: inmap
call in_open_map( map, inmap, key )
if ( inmap <= 0 .or. inmap > size( map % inverse, kind=int_index ) ) &
then
present = .false.
else
present = associated( map % inverse(inmap) % target )
end if
end subroutine open_key_test
end submodule stdlib_hashmap_open
fortran-lang-stdlib-0ede301/src/hashmaps/stdlib_hashmaps.f90 0000664 0001750 0001750 00000131005 15135654166 024246 0 ustar alastair alastair !! The module, STDLIB_HASH_MAPS, implements two hash maps:
!! CHAINING_HASH_MAP_TYPE, a separate chaining hash map; and OPEN_HASH_MAP_TYPE,
!! an open addressing hash map using linear addressing. The two hash maps are
!! implementations of the abstract type, HASH_MAP_TYPE.
module stdlib_hashmaps
use, intrinsic :: iso_fortran_env, only: &
character_storage_size, &
error_unit
use stdlib_kinds, only: &
dp, &
int8, &
int16, &
int32, &
int64
use stdlib_hashmap_wrappers, only: &
copy_key, &
fibonacci_hash, &
default_hasher => fnv_1_hasher, &
hasher_fun, &
operator(==), &
set, &
key_type, &
int_hash
implicit none
private
!! Public data_types
public :: &
chaining_hashmap_type, &
open_hashmap_type
!! Values that parameterize David Chase's empirical SLOT expansion code
integer, parameter :: &
inmap_probe_factor = 10, &
map_probe_factor = 5
!! Values that parameterize the SLOTS table size
integer, parameter, public :: &
default_bits = 6, &
max_bits = 30
!! KIND values used to parameterixe the hash map and its procedures
integer, parameter, public :: &
int_calls = int64, &
int_depth = int64, &
int_index = int32, &
int_probes = int64
!! Error codes returned by the hash map procedures
integer, parameter, public :: &
success = 0, &
alloc_fault = 1, &
array_size_error = 2
! The number of bits used by various types
integer, parameter :: &
! Should be 8
int8_bits = bit_size(0_int8), &
char_bits = character_storage_size
!! The hash map load factor
real, parameter, public :: &
load_factor = 0.5625
!! The size of the pools of allocated map entries
integer(int32), parameter :: pool_size = 64
character(*), parameter, private :: module_name = 'STDLIB_HASHMAPS'
type, abstract :: hashmap_type
!! Version: Experimental
!!
!! Type implementing an abstract hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#the-hashmap_type-abstract-type))
private
integer(int_calls) :: call_count = 0
!! Number of calls
integer(int_calls) :: probe_count = 0
!! Number of probes since last expansion
integer(int_calls) :: total_probes = 0
!! Cumulative number of probes
integer(int_index) :: num_entries = 0
!! Number of entries
integer(int_index) :: num_free = 0
!! Number of elements in the free_list
integer(int32) :: nbits = default_bits
!! Number of bits used to address the slots
procedure(hasher_fun), pointer, nopass :: hasher => default_hasher
!! Hash function
logical :: initialized = .false.
contains
procedure, non_overridable, pass(map) :: calls
procedure, non_overridable, pass(map) :: entries
procedure, non_overridable, pass(map) :: map_probes
procedure, non_overridable, pass(map) :: num_slots
procedure, non_overridable, pass(map) :: slots_bits
procedure(get_all_keys), deferred, pass(map) :: get_all_keys
procedure(init_map), deferred, pass(map) :: init
procedure(loading), deferred, pass(map) :: loading
procedure(rehash_map), deferred, pass(map) :: rehash
procedure(total_depth), deferred, pass(map) :: total_depth
!! Key_test procedures.
procedure(key_key_test), deferred, pass(map) :: key_key_test
procedure, non_overridable, pass(map) :: int8_key_test
procedure, non_overridable, pass(map) :: int32_key_test
procedure, non_overridable, pass(map) :: char_key_test
generic, public :: key_test => key_key_test, int8_key_test, int32_key_test, char_key_test
! Map_entry procedures
procedure(key_map_entry), deferred, pass(map) :: key_map_entry
procedure, non_overridable, pass(map) :: int8_map_entry
procedure, non_overridable, pass(map) :: int32_map_entry
procedure, non_overridable, pass(map) :: char_map_entry
generic, public :: map_entry => key_map_entry, int8_map_entry, int32_map_entry, char_map_entry
! Get_other_data procedures
procedure(key_get_other_data), deferred, pass(map) :: key_get_other_data
procedure, non_overridable, pass(map) :: int8_get_other_data
procedure, non_overridable, pass(map) :: int32_get_other_data
procedure, non_overridable, pass(map) :: char_get_other_data
generic, public :: get_other_data => key_get_other_data, int8_get_other_data, int32_get_other_data, char_get_other_data
! Key_remove_entry procedures
procedure(key_remove_entry), deferred, pass(map) :: key_remove_entry
procedure, non_overridable, pass(map) :: int8_remove_entry
procedure, non_overridable, pass(map) :: int32_remove_entry
procedure, non_overridable, pass(map) :: char_remove_entry
generic, public :: remove => key_remove_entry, int8_remove_entry, int32_remove_entry, char_remove_entry
! Set_other_data procedures
procedure(key_set_other_data), deferred, pass(map) :: key_set_other_data
procedure, non_overridable, pass(map) :: int8_set_other_data
procedure, non_overridable, pass(map) :: int32_set_other_data
procedure, non_overridable, pass(map) :: char_set_other_data
generic, public :: set_other_data => key_set_other_data, int8_set_other_data, int32_set_other_data, char_set_other_data
end type hashmap_type
abstract interface
subroutine get_all_keys(map, all_keys)
!! Version: Experimental
!!
!! Returns the all keys contained in a hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#get_all_keys-returns-all-the-keys-contained-in-a-map))
!!
!! Arguments:
!! map - a hash map
!! all_keys - all the keys contained in a hash map
!
import hashmap_type, key_type
class(hashmap_type), intent(in) :: map
type(key_type), allocatable, intent(out) :: all_keys(:)
end subroutine get_all_keys
subroutine key_get_other_data( map, key, other, exists )
!! Version: Experimental
!!
!! Returns the other data associated with the inverse table index
!! Arguments:
!! map - a hash map
!! key - the key associated with a map entry
!! other - the other data associated with the key
!! exists - a logical flag indicating whether an entry with that key exists
!
import hashmap_type, key_type
class(hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), allocatable, intent(out) :: other
logical, intent(out), optional :: exists
end subroutine key_get_other_data
subroutine init_map( map, &
hasher, &
slots_bits, &
status )
!! Version: Experimental
!!
!! Routine to allocate an empty map with HASHER as the hash function,
!! 2**SLOTS_BITS initial SIZE(map % slots), SIZE(map % slots) limited to a
!! maximum of 2**MAX_BITS, and with up to LOAD_FACTOR * SIZE(map % slots),
!! map % inverse elements. All fields are initialized.
!! Arguments:
!! map - the hash maap to be initialized
!! hasher - the hash function to be used to map keys to slots
!! slots_bits - the number of bits initially used to map to the slots
!! status - an integer error status flag with the allowed values:
!! success - no problems were found
!! alloc_fault - map % slots or map % inverse could not be allocated
!! array_size_error - slots_bits or max_bits is less than
!! default_bits or greater than strict_max_bits
!! real_value_error - load_factor is less than 0.375 or greater than
!! 0.875
!
import hashmap_type, hasher_fun, int32
class(hashmap_type), intent(out) :: map
procedure(hasher_fun), optional :: hasher
integer, intent(in), optional :: slots_bits
integer(int32), intent(out), optional :: status
end subroutine init_map
subroutine key_key_test(map, key, present)
!! Version: Experimental
!!
!! Returns a logical flag indicating whether KEY exists in the hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#key_test-indicates-whether-key-is-present))
!!
!! Arguments:
!! map - the hash map of interest
!! key - the key of interest
!! present - a flag indicating whether key is present in the map
!
import hashmap_type, key_type
class(hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out) :: present
end subroutine key_key_test
pure function loading( map )
!! Version: Experimental
!!
!! Returns the number of entries relative to slots in a hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#loading-returns-the-ratio-of-entries-to-slots))
!!
!! Arguments:
!! map - a hash map
import hashmap_type
class(hashmap_type), intent(in) :: map
real :: loading
end function loading
subroutine key_map_entry(map, key, other, conflict)
!! Version: Experimental
!!
!! Inserts an entry into the hash table
!! ([Specifications](../page/specs/stdlib_hashmaps.html#map_entry-inserts-an-entry-into-the-hash-map))
!!
import hashmap_type, key_type
class(hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in), optional :: other
logical, intent(out), optional :: conflict
end subroutine key_map_entry
subroutine rehash_map( map, hasher )
!! Version: Experimental
!!
!! Changes the hashing method of the table entries to that of HASHER.
!! Arguments:
!! map the table to be rehashed
!! hasher the hasher function to be used for the table
!
import hashmap_type, hasher_fun
class(hashmap_type), intent(inout) :: map
procedure(hasher_fun) :: hasher
end subroutine rehash_map
subroutine key_remove_entry(map, key, existed) ! Chase's delent
!! Version: Experimental
!!
!! Remove the entry, if any, that has the key
!! Arguments:
!! map - the table from which the entry is to be removed
!! key - the key to an entry
!! existed - a logical flag indicating whether an entry with the key
!! was present in the original map
!
import hashmap_type, key_type
class(hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out), optional :: existed
end subroutine key_remove_entry
subroutine key_set_other_data( map, key, other, exists )
!! Version: Experimental
!!
!! Change the other data associated with the key
!! Arguments:
!! map - the map with the entry of interest
!! key - the key to the entry inthe map
!! other - the new data to be associated with the key
!! exists - a logical flag indicating whether the key is already entered
!! in the map
!!
!
import hashmap_type, key_type
class(hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in) :: other
logical, intent(out), optional :: exists
end subroutine key_set_other_data
function total_depth( map )
!! Version: Experimental
!!
!! Returns the total number of ones based offsets of slot entriesyy from
!! their slot index for a hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#total_depth-returns-the-total-depth-of-the-hash-map-entries))
!! Arguments:
!! map - a hash map
import hashmap_type, int64
class(hashmap_type), intent(in) :: map
integer(int64) :: total_depth
end function total_depth
end interface
!! API for the chaining_hashmap_type
type :: chaining_map_entry_type ! Hash entry
!! Version: Experimental
!!
!! Chaining hash map entry type
!! ([Specifications](../page/specs/stdlib_hashmaps.html#the-chaining_map_entry_type-derived-type))
private
integer(int_hash) :: hash_val
!! Full hash value
type(key_type) :: key
!! The entry's key
class(*), allocatable :: other
!! Other entry data
integer(int_index) :: inmap
!! Index into inverse table
type(chaining_map_entry_type), pointer :: next => null()
!! Next bucket
end type chaining_map_entry_type
type chaining_map_entry_ptr
!! Version: Experimental
!!
!! Wrapper for a pointer to a chaining map entry type object
!! ([Specifications](../page/specs/stdlib_hashmaps.html#the-chaining_map_entry_type_ptr-derived-type))
type(chaining_map_entry_type), pointer :: target => null()
end type chaining_map_entry_ptr
type :: chaining_map_entry_pool
!! Version: Experimental
!!
!! Type implementing a pool of allocated `chaining_map_entry_type`
!! ([Specifications](../page/specs/stdlib_hashmaps.html#the-chaining_map_entry_pool-derived-type))
private
! Index of next bucket
integer(int_index) :: next = 0
type(chaining_map_entry_type), allocatable :: more_map_entries(:)
type(chaining_map_entry_pool), pointer :: lastpool => null()
end type chaining_map_entry_pool
type, extends(hashmap_type) :: chaining_hashmap_type
!! Version: Experimental
!!
!! Type implementing the `chaining_hashmap_type` types
!! ([Specifications](../page/specs/stdlib_hashmaps.html#the-chaining_hashmap_type-derived-type))
private
type(chaining_map_entry_pool), pointer :: cache => null()
!! Pool of allocated chaining_map_entry_type objects
type(chaining_map_entry_type), pointer :: free_list => null()
!! free list of map entries
type(chaining_map_entry_ptr), allocatable :: inverse(:)
!! Array of bucket lists (inverses) Note max_elts=size(inverse)
type(chaining_map_entry_ptr), allocatable :: slots(:)
!! Array of bucket lists Note # slots=size(slots)
contains
procedure :: get_all_keys => get_all_chaining_keys
procedure :: key_get_other_data => get_other_chaining_data
procedure :: init => init_chaining_map
procedure :: loading => chaining_loading
procedure :: key_map_entry => map_chain_entry
procedure :: rehash => rehash_chaining_map
procedure :: key_remove_entry => remove_chaining_entry
procedure :: key_set_other_data => set_other_chaining_data
procedure :: total_depth => total_chaining_depth
procedure :: key_key_test => chaining_key_test
final :: free_chaining_map
end type chaining_hashmap_type
interface
module subroutine free_chaining_map( map )
!! Version: Experimental
!!
!! Frees internal memory of an chaining map
!! Arguments:
!! map - the chaining hash map whose memory is to be freed
!
type(chaining_hashmap_type), intent(inout) :: map
end subroutine free_chaining_map
module subroutine get_all_chaining_keys(map, all_keys)
!! Version: Experimental
!!
!! Returns all the keys contained in a hashmap
!! Arguments:
!! map - an chaining hash map
!! all_keys - all the keys contained in a hash map
!
class(chaining_hashmap_type), intent(in) :: map
type(key_type), allocatable, intent(out) :: all_keys(:)
end subroutine get_all_chaining_keys
module subroutine get_other_chaining_data( map, key, other, exists )
!! Version: Experimental
!!
!! Returns the other data associated with the inverse table index
!! Arguments:
!! map - a chaining hash table
!! key - the key associated with a map entry
!! other - the other data associated with the key
!! exists - a logical flag indicating whether an entry with that key exists
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), allocatable, intent(out) :: other
logical, intent(out), optional :: exists
end subroutine get_other_chaining_data
module subroutine init_chaining_map( map, &
hasher, &
slots_bits, &
status )
!! Version: Experimental
!!
!! Routine to allocate an empty map with HASHER as the hash function,
!! 2**SLOTS_BITS initial SIZE(map % slots), and SIZE(map % slots) limited
!! to a maximum of 2**MAX_BITS. All fields are initialized.
!! Arguments:
!! map - the chaining hash map to be initialized
!! hasher - the hash function to be used to map keys to slots
!! slots_bits - the bits of two used to initialize the number of slots
!! status - an integer error status flag with the allowed values:
!! success - no problems were found
!! alloc_fault - map % slots or map % inverse could not be allocated
!! array_size_error - slots_bits is less than default_bits or
!! greater than max_bits
!
class(chaining_hashmap_type), intent(out) :: map
procedure(hasher_fun), optional :: hasher
integer, intent(in), optional :: slots_bits
integer(int32), intent(out), optional :: status
end subroutine init_chaining_map
module subroutine chaining_key_test(map, key, present)
!! Version: Experimental
!!
!! Returns a logical flag indicating whether KEY is present in the hash map
!! Arguments:
!! map - the hash map of interest
!! key - the key of interest
!! present - a logical flag indicating whether key is present in map
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out) :: present
end subroutine chaining_key_test
pure module function chaining_loading( map )
!! Version: Experimental
!!
!! Returns the number of entries relative to slots in a hash map
!! Arguments:
!! map - a chaining hash map
class(chaining_hashmap_type), intent(in) :: map
real :: chaining_loading
end function chaining_loading
module subroutine map_chain_entry(map, key, other, conflict)
!
! Inserts an entry innto the hash map
! Arguments:
!! map - the hash table of interest
!! key - the key identifying the entry
!! other - other data associated with the key
!! conflict - logical flag indicating whether the entry key conflicts
!! with an existing key
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in), optional :: other
logical, intent(out), optional :: conflict
end subroutine map_chain_entry
module subroutine rehash_chaining_map( map, hasher )
!! Version: Experimental
!!
!! Changes the hashing method of the table entries to that of HASHER.
!! Arguments:
!! map the table to be rehashed
!! hasher the hasher function to be used for the table
!
class(chaining_hashmap_type), intent(inout) :: map
procedure(hasher_fun) :: hasher
end subroutine rehash_chaining_map
module subroutine remove_chaining_entry(map, key, existed)
!! Version: Experimental
!!
!! Remove the entry, if any, that has the key
!! Arguments:
!! map - the table from which the entry is to be removed
!! key - the key to an entry
!! existed - a logical flag indicating whether an entry with the key
!! was present in the original map
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out), optional :: existed
end subroutine remove_chaining_entry
module subroutine set_other_chaining_data( map, key, other, exists )
!! Version: Experimental
!!
!! Change the other data associated with the key
!! Arguments:
!! map - the map with the entry of interest
!! key - the key to the entry inthe map
!! other - the new data to be associated with the key
!! exists - a logical flag indicating whether the key is already entered
!! in the map
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in) :: other
logical, intent(out), optional :: exists
end subroutine set_other_chaining_data
module function total_chaining_depth( map ) result(total_depth)
!! Version: Experimental
!!
!! Returns the total number of ones based offsets of slot entries from
!! their slot index for a hash map
!! Arguments:
!! map - an chaining hash map
class(chaining_hashmap_type), intent(in) :: map
integer(int_depth) :: total_depth
end function total_chaining_depth
end interface
!! API for the open_hashmap_type
type :: open_map_entry_type
!! Version: Experimental
!!
!! Open hash map entry type
!! ([Specifications](../page/specs/stdlib_hashmaps.html#the-open_map_entry_type-derived-type))
private
integer(int_hash) :: hash_val
!! Full hash value
type(key_type) :: key
!! Hash entry key
class(*), allocatable :: other
!! Other entry data
integer(int_index) :: inmap
!! Index into inverse table
end type open_map_entry_type
type :: open_map_entry_list
!! Version: Experimental
!!
!! Open hash map entry type
private
type(open_map_entry_type), pointer :: target => null()
type(open_map_entry_list), pointer :: next => null()
end type open_map_entry_list
type open_map_entry_ptr
!! Version: Experimental
!!
!! Wrapper for a pointer to an open hash map entry type object
!! ([Specifications](../page/specs/stdlib_hashmaps.html#the-open_map_entry_ptr-derived-type))
type(open_map_entry_type), pointer :: target => null()
end type open_map_entry_ptr
type :: open_map_entry_pool
!! Version: Experimental
!!
!! Type implementing a pool of allocated `open_map_entry_type`
private
integer(int_index) :: next = 0
!! Index of next bucket
type(open_map_entry_type), allocatable :: more_map_entries(:)
type(open_map_entry_pool), pointer :: lastpool => null()
end type open_map_entry_pool
type, extends(hashmap_type) :: open_hashmap_type
!! Version: Experimental
!!
!! Type implementing an "open" hash map
private
integer(int_index) :: index_mask = 2_int_index**default_bits-1
!! Mask used in linear addressing
type(open_map_entry_pool), pointer :: cache => null()
!! Pool of allocated open_map_entry_type objects
type(open_map_entry_list), pointer :: free_list => null()
!! free list of map entries
type(open_map_entry_ptr), allocatable :: inverse(:)
!! Array of bucket lists (inverses) Note max_elts=size(inverse)
integer(int_index), allocatable :: slots(:)
!! Array of indices to the inverse Note # slots=size(slots)
contains
procedure :: get_all_keys => get_all_open_keys
procedure :: key_get_other_data => get_other_open_data
procedure :: init => init_open_map
procedure :: loading => open_loading
procedure :: key_map_entry => map_open_entry
procedure :: rehash => rehash_open_map
procedure :: key_remove_entry => remove_open_entry
procedure :: key_set_other_data => set_other_open_data
procedure :: total_depth => total_open_depth
procedure :: key_key_test => open_key_test
final :: free_open_map
end type open_hashmap_type
interface
module subroutine free_open_map( map )
!! Version: Experimental
!!
!! Frees internal memory of an open map
!! Arguments:
!! map - the open hash map whose memory is to be freed
!
type(open_hashmap_type), intent(inout) :: map
end subroutine free_open_map
module subroutine get_all_open_keys(map, all_keys)
!! Version: Experimental
!!
!! Returns all the keys contained in a hashmap
!! Arguments:
!! map - an open hash map
!! all_keys - all the keys contained in a hash map
!
class(open_hashmap_type), intent(in) :: map
type(key_type), allocatable, intent(out) :: all_keys(:)
end subroutine get_all_open_keys
module subroutine get_other_open_data( map, key, other, exists )
!! Version: Experimental
!!
!! Returns the other data associated with the inverse table index
!! Arguments:
!! map - an open hash table
!! key - the key associated with a map entry
!! other - the other data associated with the key
!! exists - a logical flag indicating whether an entry with that key exists
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), allocatable, intent(out) :: other
logical, intent(out), optional :: exists
end subroutine get_other_open_data
module subroutine init_open_map( map, &
hasher, &
slots_bits, &
status )
!! Version: Experimental
!!
!! Routine to allocate an empty map with HASHER as the hash function,
!! 2**SLOTS_BITS initial SIZE(map % slots), and SIZE(map % slots) limited to a
!! maximum of 2**MAX_BITS. All fields are initialized.
!! Arguments:
!! map - the open hash maap to be initialized
!! hasher - the hash function to be used to map keys to slots
!! slots_bits - the number of bits used to map to the slots
!! status - an integer error status flag with the allowed values:
!! success - no problems were found
!! alloc_fault - map % slots or map % inverse could not be allocated
!! array_size_error - slots_bits is less than default_bitd or
!! greater than max_bits
class(open_hashmap_type), intent(out) :: map
procedure(hasher_fun), optional :: hasher
integer, intent(in), optional :: slots_bits
integer(int32), intent(out), optional :: status
end subroutine init_open_map
module subroutine open_key_test(map, key, present)
!! Version: Experimental
!!
!! Returns a logical flag indicating whether KEY exists in the hash map
!! Arguments:
!! map - the hash map of interest
!! key - the key of interest
!! present - a logical flag indicating whether KEY exists in the hash map
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out) :: present
end subroutine open_key_test
pure module function open_loading( map )
!! Version: Experimental
!!
!! Returns the number of entries relative to slots in a hash map
!! Arguments:
!! map - an open hash map
class(open_hashmap_type), intent(in) :: map
real :: open_loading
end function open_loading
module subroutine map_open_entry(map, key, other, conflict)
!! Version: Experimental
!!
!! Inserts an entry into the hash table
!! Arguments:
!! map - the hash table of interest
!! key - the key identifying the entry
!! other - other data associated with the key
!! conflict - logical flag indicating whether the entry key conflicts
!! with an existing key
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in), optional :: other
logical, intent(out), optional :: conflict
end subroutine map_open_entry
module subroutine rehash_open_map( map, hasher )
!! Version: Experimental
!!
!! Changes the hashing method of the table entries to that of HASHER.
!! Arguments:
!! map the table to be rehashed
!! hasher the hasher function to be used for the table
!
class(open_hashmap_type), intent(inout) :: map
procedure(hasher_fun) :: hasher
end subroutine rehash_open_map
module subroutine remove_open_entry(map, key, existed)
!! Remove the entry, if any, that has the key
!! Arguments:
!! map - the table from which the entry is to be removed
!! key - the key to an entry
!! existed - a logical flag indicating whether an entry with the key
!! was present in the original map
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out), optional :: existed
end subroutine remove_open_entry
module subroutine set_other_open_data( map, key, other, exists )
!! Version: Experimental
!!
!! Change the other data associated with the key
!! Arguments:
!! map - the map with the entry of interest
!! key - the key to the entry inthe map
!! other - the new data to be associated with the key
!! exists - a logical flag indicating whether the key is already entered
!! in the map
!
class(open_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in) :: other
logical, intent(out), optional :: exists
end subroutine set_other_open_data
module function total_open_depth( map ) result(total_depth)
!! Version: Experimental
!!
!! Returns the total number of ones based offsets of slot entries from
!! their slot index for a hash map
!! Arguments:
!! map - an open hash map
class(open_hashmap_type), intent(in) :: map
integer(int64) :: total_depth
end function total_open_depth
end interface
contains
subroutine int8_get_other_data( map, value, other, exists )
!! Version: Experimental
!!
!! Int8 key generic interface for get_other_data function
class(hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: value(:)
class(*), allocatable, intent(out) :: other
logical, intent(out), optional :: exists
type(key_type) :: key
call set( key, value )
call map % key_get_other_data( key, other, exists )
end subroutine int8_get_other_data
subroutine int32_get_other_data( map, value, other, exists )
!! Version: Experimental
!!
!! Int32 key generic interface for get_other_data function
class(hashmap_type), intent(inout) :: map
integer(int32), intent(in) :: value(:)
class(*), allocatable, intent(out) :: other
logical, intent(out), optional :: exists
type(key_type) :: key
call set( key, value )
call map % key_get_other_data( key, other, exists )
end subroutine int32_get_other_data
subroutine char_get_other_data( map, value, other, exists )
!! Version: Experimental
!!
!! Character key generic interface for get_other_data function
class(hashmap_type), intent(inout) :: map
character(*), intent(in) :: value
class(*), allocatable, intent(out) :: other
logical, intent(out), optional :: exists
type(key_type) :: key
call set( key, value )
call map % key_get_other_data( key, other, exists )
end subroutine char_get_other_data
subroutine int8_remove_entry(map, value, existed) ! Chase's delent
!! Version: Experimental
!!
!! Remove the entry, if any, that has the key
!! Arguments:
!! map - the table from which the entry is to be removed
!! value - the int8 array key to an entry
!! existed - a logical flag indicating whether an entry with the key
!! was present in the original map
!
class(hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: value(:)
logical, intent(out), optional :: existed
type(key_type) :: key
call set( key, value )
call map % key_remove_entry( key, existed )
end subroutine int8_remove_entry
subroutine int32_remove_entry(map, value, existed) ! Chase's delent
!! Version: Experimental
!!
!! Remove the entry, if any, that has the key
!! Arguments:
!! map - the table from which the entry is to be removed
!! key - the key to an entry
!! existed - a logical flag indicating whether an entry with the key
!! was present in the original map
!
class(hashmap_type), intent(inout) :: map
integer(int32), intent(in) :: value(:)
logical, intent(out), optional :: existed
type(key_type) :: key
call set( key, value )
call map % key_remove_entry( key, existed )
end subroutine int32_remove_entry
subroutine char_remove_entry(map, value, existed) ! Chase's delent
!! Version: Experimental
!!
!! Remove the entry, if any, that has the key
!! Arguments:
!! map - the table from which the entry is to be removed
!! key - the key to an entry
!! existed - a logical flag indicating whether an entry with the key
!! was present in the original map
!
class(hashmap_type), intent(inout) :: map
character(*), intent(in) :: value
logical, intent(out), optional :: existed
type(key_type) :: key
call set( key, value )
call map % key_remove_entry( key, existed )
end subroutine char_remove_entry
subroutine int8_map_entry(map, value, other, conflict)
!! Version: Experimental
!! Int8 generic interface for map entry
!! ([Specifications](../page/specs/stdlib_hashmaps.html#map_entry-inserts-an-entry-into-the-hash-map))
!!
class(hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: value(:)
class(*), intent(in), optional :: other
logical, intent(out), optional :: conflict
type(key_type) :: key
call set( key, value )
call map % key_map_entry( key, other, conflict )
end subroutine int8_map_entry
subroutine int32_map_entry(map, value, other, conflict)
!! Version: Experimental
!!
!! Inserts an entry into the hash table
!! ([Specifications](../page/specs/stdlib_hashmaps.html#map_entry-inserts-an-entry-into-the-hash-map))
!!
class(hashmap_type), intent(inout) :: map
integer(int32), intent(in) :: value(:)
class(*), intent(in), optional :: other
logical, intent(out), optional :: conflict
type(key_type) :: key
call set( key, value )
call map % key_map_entry( key, other, conflict )
end subroutine int32_map_entry
subroutine char_map_entry(map, value, other, conflict)
!! Version: Experimental
!!
!! Inserts an entry into the hash table
!! ([Specifications](../page/specs/stdlib_hashmaps.html#map_entry-inserts-an-entry-into-the-hash-map))
!!
class(hashmap_type), intent(inout) :: map
character(len=*), intent(in) :: value
class(*), intent(in), optional :: other
logical, intent(out), optional :: conflict
type(key_type) :: key
call set( key, value )
call map % key_map_entry( key, other, conflict )
end subroutine char_map_entry
subroutine int8_key_test(map, value, present)
!! Version: Experimental
!!
!! Returns a logical flag indicating whether KEY exists in the hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#key_test-indicates-whether-key-is-present))
!!
!! Arguments:
!! map - the hash map of interest
!! value - int8 array that is the key to lookup.
!! present - a flag indicating whether key is present in the map
!
class(hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: value(:)
logical, intent(out) :: present
type(key_type) :: key
! Generate key from int8 array.
call set( key, value )
! Call key test procedure.
call map % key_key_test( key, present )
end subroutine int8_key_test
subroutine int32_key_test(map, value, present)
!! Version: Experimental
!!
!! Returns a logical flag indicating whether KEY exists in the hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#key_test-indicates-whether-key-is-present))
!!
!! Arguments:
!! map - the hash map of interest
!! value - int32 array that is the key to lookup.
!! present - a flag indicating whether key is present in the map
!
class(hashmap_type), intent(inout) :: map
integer(int32), intent(in) :: value(:)
logical, intent(out) :: present
type(key_type) :: key
call set( key, value )
call map % key_key_test( key, present )
end subroutine int32_key_test
subroutine char_key_test(map, value, present)
!! Version: Experimental
!!
!! Returns a logical flag indicating whether KEY exists in the hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#key_test-indicates-whether-key-is-present))
!!
!! Arguments:
!! map - the hash map of interest
!! value - char array that is the key to lookup.
!! present - a flag indicating whether key is present in the map
!
class(hashmap_type), intent(inout) :: map
character(*), intent(in) :: value
logical, intent(out) :: present
type(key_type) :: key
call set( key, value )
call map % key_key_test( key, present )
end subroutine char_key_test
subroutine int8_set_other_data( map, value, other, exists )
!! Version: Experimental
!!
!! Change the other data associated with the key
!! Arguments:
!! map - the map with the entry of interest
!! value - the int8 array key to the entry inthe map
!! other - the new data to be associated with the key
!! exists - a logical flag indicating whether the key is already entered
!! in the map
!!
!
class(hashmap_type), intent(inout) :: map
integer(int8), intent(in) :: value(:)
class(*), intent(in) :: other
logical, intent(out), optional :: exists
type(key_type) :: key
call set( key, value )
call map % key_set_other_data( key, other, exists )
end subroutine int8_set_other_data
subroutine int32_set_other_data( map, value, other, exists )
!! Version: Experimental
!!
!! Change the other data associated with the key
!! Arguments:
!! map - the map with the entry of interest
!! value - the int32 array key to the entry inthe map
!! other - the new data to be associated with the key
!! exists - a logical flag indicating whether the key is already entered
!! in the map
!!
!
class(hashmap_type), intent(inout) :: map
integer(int32), intent(in) :: value(:)
class(*), intent(in) :: other
logical, intent(out), optional :: exists
type(key_type) :: key
call set( key, value )
call map % key_set_other_data( key, other, exists )
end subroutine int32_set_other_data
subroutine char_set_other_data( map, value, other, exists )
!! Version: Experimental
!!
!! Change the other data associated with the key
!! Arguments:
!! map - the map with the entry of interest
!! value - the char value key to the entry inthe map
!! other - the new data to be associated with the key
!! exists - a logical flag indicating whether the key is already entered
!! in the map
!!
!
class(hashmap_type), intent(inout) :: map
character(*), intent(in) :: value
class(*), intent(in) :: other
logical, intent(out), optional :: exists
type(key_type) :: key
call set( key, value )
call map % key_set_other_data( key, other, exists )
end subroutine char_set_other_data
pure function calls( map )
!! Version: Experimental
!!
!! Returns the number of subroutine calls on an open hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#calls-returns-the-number-of-calls-on-the-hash-map))
!!
!! Arguments:
!! map - an open hash map
class(hashmap_type), intent(in) :: map
integer(int_calls) :: calls
calls = map % call_count
end function calls
pure function entries( map )
!! Version: Experimental
!!
!! Returns the number of entries in a hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#entries-returns-the-number-of-entries-in-the-hash-map))
!!
!! Arguments:
!! map - an open hash map
class(hashmap_type), intent(in) :: map
integer(int_index) :: entries
entries = map % num_entries
end function entries
pure function map_probes( map )
!! Version: Experimental
!!
!! Returns the total number of table probes on a hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#map_probes-returns-the-number-of-hash-map-probes))
!!
!! Arguments:
!! map - an open hash map
class(hashmap_type), intent(in) :: map
integer(int_calls) :: map_probes
map_probes = map % total_probes + map % probe_count
end function map_probes
pure function num_slots( map )
!! Version: Experimental
!!
!! Returns the number of allocated slots in a hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#num_slots-returns-the-number-of-hash-map-slots))
!!
!! Arguments:
!! map - an open hash map
class(hashmap_type), intent(in) :: map
integer(int_index) :: num_slots
num_slots = 2**map % nbits
end function num_slots
pure function slots_bits( map )
!! Version: Experimental
!!
!! Returns the number of bits used to specify the number of allocated
!! slots in a hash map
!! ([Specifications](../page/specs/stdlib_hashmaps.html#slots_bits-returns-the-number-of-bits-used-to-address-the-hash-map-slots))
!!
!! Arguments:
!! map - an open hash map
class(hashmap_type), intent(in) :: map
integer :: slots_bits
slots_bits = map % nbits
end function slots_bits
end module stdlib_hashmaps
fortran-lang-stdlib-0ede301/src/hashmaps/stdlib_hashmap_chaining.f90 0000664 0001750 0001750 00000077245 15135654166 025742 0 ustar alastair alastair !! The module STDLIB_HASHMAP_CHAINING implements a simple separate
!! chaining hash map. The implementation is loosely based on a C
!! implementation by David Chase, http://chasewoerner.org/src/hasht/, for
!! which he has given permission to use in the Fortran Standard Library.
! Note an error in the code caused attempts to deallocate already deallocated
! entries. This did not cause stat to be non-zero, but did cause system errors,
! on my Mac. I therefore decided to remove all deallocation error reporting.
submodule(stdlib_hashmaps) stdlib_hashmap_chaining
!! Version: Experimental
!!
!! Implements a simple separate chaining hash map.
implicit none
! Error messages
character(len=*), parameter :: &
alloc_inv_fault = "CHAINING_HASHMAP_TYPE % INVERSE allocation " // &
"fault.", &
alloc_slots_fault = "CHAINING_HASHMAP_TYPE % SLOTS allocation " // &
"fault.", &
conflicting_key = "KEY already exists in MAP.", &
expand_slots_fail = "CHAINING_HASHMAP_TYPE % SLOTS allocation > " // &
"max bits.", &
init_slots_pow_fail = "SLOT_BITS is not between DEFAULT_BITS " // &
"and MAX_BITS.", &
invalid_inmap = "INMAP was not a valid INVERSE index.", &
map_consist_fault = "The hash map found a inconsistency."
character(len=*), parameter :: submodule_name = "STDLIB_HASHMAP_CHAINING"
interface expand_slots
!! Version: Experimental
!!
!! Interface to internal procedure that expands the number of map slots.
module procedure expand_chaining_slots
end interface expand_slots
interface extend_map_entry_pool
!! Version: Experimental
!!
!! Interface to internal procedure that expands a chaining map entry pool.
module procedure extend_chaining_map_entry_pool
end interface extend_map_entry_pool
interface free_map
!! Version: Experimental
!!
!! Interface to procedure that finalizes a chaining hash map.
module procedure free_chaining_map
end interface free_map
interface free_map_entry_pool
!! Version: Experimental
!!
!! Interface to internal procedure that finalizes a chaining hash map
!! entry pool.
module procedure free_map_entry_pool
end interface free_map_entry_pool
interface get_other_data
!! Version: Experimental
!!
!! Interface to procedure that gets an entry's other data.
module procedure get_other_chaining_data
end interface get_other_data
interface init
!! Version: Experimental
!!
!! Interface to initialization procedure for a chaining hash map.
module procedure init_chaining_map
end interface init
interface rehash
!! Version: Experimental
!!
!! Interface to a procedure that changes the hash function that
!! is used to map the keys into a chaining hash map.
module procedure rehash_chaining_map
end interface rehash
interface remove
!! Version: Experimental
!!
!! Interface to a procedure that removes the entry associated with a key
module procedure remove_chaining_entry ! Chase's delent
end interface remove
interface set_other_data
!! Version: Experimental
!!
!! Interface to a procedure that changes the other data associated with a key
module procedure set_other_chaining_data
end interface set_other_data
contains
! Internal routine to make a duplicate map with more hash slots.
! Note David Chase had pointer returning functions, but the logic did not
! depend on the result value
subroutine expand_chaining_slots( map )
!! Version: Experimental
!!
!! Internal routine to make a duplicate map with more hash slots.
!! Doubles the size of the map % slots array
!! Arguments:
!! map - the hash map whose hash slots are to be expanded
!
type(chaining_hashmap_type), intent(inout) :: map
type(chaining_map_entry_type), pointer :: current_entry
type(chaining_map_entry_ptr), allocatable :: dummy_slots(:)
integer(int_index) :: min_size, new_size
integer(int_index) :: old_size, &
slot_index
integer(int32) :: bits, &
stat
character(256) :: errmsg
character(*), parameter :: procedure = 'EXPAND_SLOTS'
if ( map % nbits == max_bits ) then
error stop submodule_name // ' % ' // procedure // ': ' // &
expand_slots_fail
end if
old_size = size(map % slots, kind=int_index)
determine_new_size: if ( map % num_entries <= old_size ) then
! Expand by factor of two to improve efficiency
new_size = 2*old_size
bits = map % nbits + 1
else
! Expand so the number of slots is no more than 2**max_bits but otherwise
! at least the number of entries
min_size = map % num_entries
new_size = old_size
bits = map % nbits
do
bits = bits + 1
new_size = new_size * 2
if ( bits >= max_bits .OR. new_size >= min_size ) exit
end do
end if determine_new_size
allocate( dummy_slots(0:new_size-1), stat=stat, errmsg=errmsg )
if (stat /= 0) then
write(error_unit, '(a)') 'Allocation ERRMSG: ' // trim(errmsg)
error stop submodule_name // ' % ' // procedure // ': ' // &
alloc_slots_fault
end if
map % nbits = bits
do slot_index=0, new_size-1
dummy_slots(slot_index) % target => null() ! May be redundant
end do
map % total_probes = map % total_probes + map % probe_count
map % probe_count = 0
! This maps old slots entries to new slots, but we could also map inverse
! entries to new_slots
do slot_index=0, old_size-1
do while( associated(map % slots(slot_index) % target) )
current_entry => map % slots(slot_index) % target
map % slots(slot_index) % target => current_entry % next
call remap( dummy_slots, current_entry, map % nbits )
end do
end do
call move_alloc( dummy_slots, map % slots )
contains
subroutine remap(slots, gentry, bits)
type(chaining_map_entry_ptr), intent(inout) :: slots(0:)
type(chaining_map_entry_type), intent(inout), target :: gentry
integer(int_hash), intent(in) :: bits
integer(int_index) :: hash_index
type(chaining_map_entry_type), pointer :: where_loc
hash_index = fibonacci_hash( gentry % hash_val, bits )
where_loc => slots(hash_index) % target
gentry % next => null() ! May be redundant
if ( associated( where_loc ) ) then
do while ( associated(where_loc % next) )
where_loc => where_loc % next
end do
where_loc % next => gentry
else
slots(hash_index) % target => gentry
end if
end subroutine remap
end subroutine expand_chaining_slots
subroutine extend_chaining_map_entry_pool(map) ! gent_pool_new
!! Version: Experimental
!!
!! Add more map_entrys to the pool head
!! Arguments:
!! pool - a chaining map entry pool
type(chaining_hashmap_type), intent(inout) :: map
type(chaining_map_entry_pool), pointer :: pool
allocate(pool)
allocate(pool % more_map_entries(0:pool_size-1))
pool % next = 0 ! may be redundant
pool % lastpool => map % cache
map % cache => pool
end subroutine extend_chaining_map_entry_pool
! Internal final routine to free a map and its memory
module subroutine free_chaining_map( map )
!! Version: Experimental
!!
!! Frees internal memory of an chaining map
!! Arguments:
!! map - the chaining hash map whose memory is to be freed
!
type(chaining_hashmap_type), intent(inout) :: map
integer(int_index) :: i
type(chaining_map_entry_type), pointer :: next
if ( allocated( map % slots ) ) then
remove_slot_links: do i=0, size( map % slots ) - 1
if ( associated( map % slots(i) % target ) ) then
map % slots(i) % target => null()
end if
end do remove_slot_links
deallocate( map % slots )
end if
if ( allocated( map % inverse) ) then
remove_links: do i=1, size( map % inverse, kind=int_index )
if ( associated( map % inverse(i) % target ) ) then
map % inverse(i) % target % next => null()
end if
map % inverse(i) % target => null()
end do remove_links
deallocate( map % inverse )
end if
free_free_list: do
if ( associated( map % free_list) ) then
next => map % free_list % next
map % free_list => next
cycle free_free_list
else
map % num_free = 0
exit free_free_list
end if
end do free_free_list
if ( associated( map % cache ) ) call free_map_entry_pool(map % cache)
map % num_entries = 0
end subroutine free_chaining_map
recursive subroutine free_map_entry_pool(pool) ! gent_pool_free
!! Version: Experimental
!!
!! Recursively descends map entry pool list freeing each element
!! Arguments:
!! pool The map entry pool whose elements are to be freed
!
type(chaining_map_entry_pool), intent(inout), pointer :: pool
if ( .not. associated(pool) ) return
call free_map_entry_pool(pool % lastpool)
deallocate( pool )
end subroutine free_map_entry_pool
module subroutine get_all_chaining_keys(map, all_keys)
!! Version: Experimental
!!
!! Returns all the keys contained in a hash map
!! Arguments:
!! map - a chaining hash map
!! all_keys - all the keys contained in a hash map
!
class(chaining_hashmap_type), intent(in) :: map
type(key_type), allocatable, intent(out) :: all_keys(:)
integer(int32) :: num_keys
integer(int_index) :: i, key_idx
num_keys = map % entries()
allocate( all_keys(num_keys) )
if ( num_keys == 0 ) return
if( allocated( map % inverse ) ) then
key_idx = 1_int_index
do i=1_int_index, size( map % inverse, kind=int_index )
if ( associated( map % inverse(i) % target ) ) then
all_keys(key_idx) = map % inverse(i) % target % key
key_idx = key_idx + 1_int_index
end if
end do
end if
end subroutine get_all_chaining_keys
module subroutine get_other_chaining_data( map, key, other, exists )
!! Version: Experimental
!!
!! Returns the other data associated with the inverse table index
!! Arguments:
!! map - a chaining hash map
!! key - the key associated with a map entry
!! other - the other data associated with the key
!! exists - a logical flag indicating whether an entry with that key exists
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), allocatable, intent(out) :: other
logical, intent(out), optional :: exists
integer(int_index) :: inmap
character(*), parameter :: procedure = 'GET_OTHER_DATA'
call in_chain_map(map, inmap, key)
if ( inmap <= 0 .or. &
inmap > size(map % inverse, kind=int_index ) ) then
if ( present(exists) ) then
exists = .false.
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
invalid_inmap
end if
else if ( associated( map % inverse(inmap) % target ) ) then
if (present(exists) ) exists = .true.
other = map % inverse(inmap) % target % other
else
if ( present(exists) ) then
exists = .false.
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
map_consist_fault
end if
end if
end subroutine get_other_chaining_data
subroutine in_chain_map(map, inmap, key)
!! Version: Experimental
!!
!! Returns the index into the INVERSE array associated with the KEY
!! Arguments:
!! map - the hash map of interest
!! inmap - the returned index into the INVERSE array of entry pointers.
!! A value of zero indicates that an entry with that key was not
!! found.
!! key - the key identifying the entry of interest
!
class(chaining_hashmap_type), intent(inout) :: map
integer(int_index), intent(out) :: inmap
type(key_type), intent(in) :: key
integer(int_hash) :: hash_val, hash_index
type(chaining_map_entry_type), pointer :: gentry, pentry, sentry
if ( map % probe_count > inmap_probe_factor * map % call_count ) then
if ( map % nbits < max_bits .AND. &
map % num_entries > size( map % slots, kind=int_index ) ) then
call expand_slots(map)
end if
end if
map % call_count = map % call_count + 1
hash_val = map % hasher( key )
hash_index = fibonacci_hash( hash_val, map % nbits )
pentry => map % slots(hash_index) % target
sentry => pentry
climb_chain: do
gentry => pentry
map % probe_count = map % probe_count + 1
if (.not. associated( gentry ) ) then
inmap = 0
return
else if ( hash_val == gentry % hash_val ) then
if ( key == gentry % key ) then
! The swap to front seems to confuse gfortran's pointers
! if ( .not. associated( pentry, sentry ) ) then
! ! swap to front
! pentry => gentry % next
! gentry % next => sentry
! sentry => gentry
! end if
inmap = gentry % inmap
return
end if
end if
pentry => gentry % next
end do climb_chain
end subroutine in_chain_map
module subroutine init_chaining_map( map, &
hasher, &
slots_bits, &
status )
!! Version: Experimental
!!
!! Routine to allocate an empty map with HASHER as the hash function,
!! 2**SLOTS_BITS initial SIZE(map % slots), and SIZE(map % slots) limited
!! to a maximum of 2**MAX_BITS. All fields are initialized.
!! Arguments:
!! map - the chaining hash map to be initialized
!! hasher - the hash function to be used to map keys to slots
!! slots_bits - the bits of two used to initialize the number of slots
!! status - an integer error status flag with the allowed values:
!! success - no problems were found
!! alloc_fault - map % slots or map % inverse could not be allocated
!! array_size_error - slots_bits is less than default_bits or
!! greater than max_bits
!
class(chaining_hashmap_type), intent(out) :: map
procedure(hasher_fun), optional :: hasher
integer, intent(in), optional :: slots_bits
integer(int32), intent(out), optional :: status
character(256) :: errmsg
integer(int_index) :: index
character(*), parameter :: procedure = 'INIT'
integer(int_index) :: slots
integer(int32) :: stat
map % call_count = 0
map % probe_count = 0
map % total_probes = 0
! Check if user has specified a hasher other than the default hasher.
if (present(hasher)) map % hasher => hasher
call free_chaining_map( map )
if ( present(slots_bits) ) then
if ( slots_bits < 6 .OR. slots_bits > max_bits ) then
if ( present(status) ) then
status = array_size_error
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
init_slots_pow_fail
end if
end if
map % nbits = slots_bits
else
map % nbits = min( default_bits, max_bits )
end if
slots = 2_int_index**map % nbits
allocate( map % slots(0:slots-1), stat=stat, errmsg=errmsg )
if ( stat /= 0 ) then
if ( present(status) ) then
status = alloc_fault
return
else
write(error_unit, '(a)') 'Allocation ERRMSG: ' // trim(errmsg)
error stop submodule_name // ' % ' // procedure // ': ' // &
alloc_slots_fault
end if
end if
do index = 0, size( map % slots, kind=int_index )-1
map % slots(index) % target => null() ! May be redundant
end do
! 5*s from Chase's g_new_map
allocate( map % inverse(1:slots), stat=stat, errmsg=errmsg )
if ( stat /= 0 ) then
if ( present( status ) ) then
status = alloc_fault
return
else
write(error_unit, '(a)') 'Allocation ERRMSG: ' // trim(errmsg)
error stop submodule_name // ' % ' // procedure // ': ' // &
alloc_inv_fault
end if
end if
do index=1, size(map % inverse, kind=int_index)
map % inverse(index) % target => null()
end do
call extend_map_entry_pool(map)
map % initialized = .true.
if (present(status) ) status = success
end subroutine init_chaining_map
pure module function chaining_loading( map )
!! Version: Experimental
!!
!! Returns the number of entries relative to slots in a hash map
!! Arguments:
!! map - a chaining hash map
class(chaining_hashmap_type), intent(in) :: map
real :: chaining_loading
chaining_loading = real( map % num_entries ) / &
real( size( map % slots, kind=int_index ) )
end function chaining_loading
module subroutine map_chain_entry(map, key, other, conflict)
!! Version: Experimental
!!
!! Inserts an entry into the hash table
!! Arguments:
!! map - the hash table of interest
!! key - the key identifying the entry
!! other - other data associated with the key
!! conflict - logical flag indicating whether the entry key conflicts
!! with an existing key
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in), optional :: other
logical, intent(out), optional :: conflict
integer(int_hash) :: hash_index
integer(int_hash) :: hash_val
integer(int_index) :: inmap
type(chaining_map_entry_type), pointer :: new_ent
type(chaining_map_entry_type), pointer :: gentry, pentry, sentry
character(*), parameter :: procedure = 'MAP_ENTRY'
! Check that map is initialized.
if (.not. map % initialized) call init_chaining_map( map )
hash_val = map % hasher( key )
if ( map % probe_count > map_probe_factor * map % call_count ) then
call expand_slots(map)
end if
map % call_count = map % call_count + 1
hash_index = fibonacci_hash( hash_val, map % nbits )
pentry => map % slots(hash_index) % target
sentry => pentry
do
gentry => pentry
map % probe_count = map % probe_count + 1
if ( .not. associated( gentry ) ) then
call allocate_chaining_map_entry( map, new_ent )
new_ent % hash_val = hash_val
! Adding to tail of chain doesn't work on gfortran
! new_ent % next => sentry
! sentry => new_ent
! Adding to head of chain works on gfortran
new_ent % next => map % slots(hash_index) % target
map % slots(hash_index) % target => new_ent
call copy_key( key, new_ent % key )
if ( present(other) ) new_ent % other = other
if ( new_ent % inmap == 0 ) then
map % num_entries = map % num_entries + 1
inmap = map % num_entries
else
inmap = new_ent % inmap
end if
if ( inmap == size( map % inverse, kind=int_index ) ) then
call expand_inverse( map )
end if
new_ent % inmap = inmap
map % inverse(inmap) % target => new_ent
if ( present(conflict) ) conflict = .false.
return
else if ( hash_val == gentry % hash_val ) then
if ( key == gentry % key ) then
inmap = gentry % inmap
if ( .not. associated( pentry, sentry ) ) then
! Swap to front
pentry => gentry % next
gentry % next => sentry
sentry => gentry
end if
if ( present(conflict) ) then
conflict = .true.
else
error stop submodule_name // ' % ' // procedure &
// ': ' // conflicting_key
end if
return
end if
end if
pentry => gentry % next
end do
contains
subroutine allocate_chaining_map_entry(map, bucket) ! Chases gent_malloc
! allocates a hash bucket
type(chaining_hashmap_type), intent(inout) :: map
type(chaining_map_entry_type), pointer, intent(out) :: bucket
type(chaining_map_entry_pool), pointer :: pool
pool => map % cache
map % num_entries = map % num_entries + 1
if ( associated(map % free_list) ) then
! Get hash bucket from free_list
bucket => map % free_list
map % free_list => bucket % next
map % num_free = map % num_free - 1
else
! Get hash bucket from pool
if ( pool % next == pool_size ) then
! Expand pool
call extend_map_entry_pool(map)
pool => map % cache
end if
bucket => pool % more_map_entries(pool % next)
pool % next = pool % next + 1 ! 0s based
if ( map % num_entries > &
size( map % inverse, kind=int_index ) ) &
then
call expand_inverse( map )
end if
bucket % inmap = map % num_entries
end if
end subroutine allocate_chaining_map_entry
subroutine expand_inverse(map)
! Increase size of map % inverse
type(chaining_hashmap_type), intent(inout) :: map
type(chaining_map_entry_ptr), allocatable :: dummy_inverse(:)
integer(int32) :: stat
character(256) :: errmsg
character(*), parameter :: procedure = 'MAP_ENTRY'
allocate( dummy_inverse( 1:2*size(map % inverse, &
kind=int_index) ), &
stat=stat, &
errmsg=errmsg )
if ( stat /= 0 ) then
write(error_unit, '(a)') 'Allocation ERRMSG: ' // trim(errmsg)
error stop submodule_name // ' % ' // procedure // ': ' // &
alloc_inv_fault
end if
dummy_inverse(1:size(map % inverse, kind=int_index)) = &
map % inverse(:)
call move_alloc( dummy_inverse, map % inverse )
end subroutine expand_inverse
end subroutine map_chain_entry
module subroutine rehash_chaining_map( map, hasher )
!! Version: Experimental
!!
!! Changes the hashing method of the table entries to that of HASHER.
!! Arguments:
!! map the table to be rehashed
!! hasher the hasher function to be used for the table
!
class(chaining_hashmap_type), intent(inout) :: map
procedure(hasher_fun) :: hasher
integer(int_hash) :: hash_val
integer(int_index) :: i
integer(int_index) :: index
map % hasher => hasher
do i=0, size( map % slots, kind=int_index ) - 1
map % slots(i) % target => null()
end do
do i=1, map % num_entries + map % num_free
if ( .not. associated( map % inverse(i) % target ) ) cycle
hash_val = map % hasher ( map % inverse(i) % target % key )
map % inverse(i) % target % hash_val = hash_val
index = fibonacci_hash( hash_val, map % nbits )
map % inverse(i) % target % inmap = i
if ( associated( map % slots(index) % target ) ) then
map % inverse(i) % target % next => map % slots(index) % target
map % slots(index) % target => map % inverse(i) % target
else
map % slots(index) % target => map % inverse(i) % target
map % slots(index) % target % next => null()
end if
end do
end subroutine rehash_chaining_map
module subroutine remove_chaining_entry(map, key, existed)
!! Remove the entry, if any, that has the key
!! Arguments:
!! map - the table from which the entry is to be removed
!! key - the key to an entry
!! existed - a logical flag indicating whether an entry with the key
!! was present in the original map
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out), optional :: existed
type(chaining_map_entry_type), pointer :: bucket, aentry, bentry, centry
integer(int_hash) :: hash_val
integer(int_index) :: inmap, k, level
call in_chain_map( map, inmap, key )
if ( inmap < 1 .or. inmap > size( map % inverse ) ) then
if ( present( existed ) ) existed = .false.
return
end if
bucket => map % inverse(inmap) % target
if ( .not. associated(bucket) ) then
if ( present( existed ) ) existed = .false.
return
end if
if ( present(existed) ) existed = .true.
hash_val = bucket % hash_val
k = fibonacci_hash( hash_val, map % nbits )
allocate(aentry)
aentry => map % slots(k) % target
if ( associated(aentry) ) then
if ( aentry % inmap == inmap ) then
bentry => aentry % next
map % slots(k) % target => bentry
aentry % next => map % free_list
map % free_list => aentry
map % inverse(inmap) % target => null()
map % num_free = map % num_free + 1
map % num_entries = map % num_entries - 1
return
end if
else
return
end if
level = 1
centry => map % slots(k) % target
aentry => aentry % next
FIND_SLOTS_ENTRY:do
if ( .not. associated(aentry) ) return
if ( aentry % inmap == inmap ) exit
centry => aentry
aentry => aentry % next
level = level + 1
end do FIND_SLOTS_ENTRY
bentry => aentry % next
aentry % next => map % free_list
map % free_list => aentry
centry % next => bentry
map % inverse(inmap) % target => null()
map % num_free = map % num_free + 1
map % num_entries = map % num_entries - 1
end subroutine remove_chaining_entry
module subroutine set_other_chaining_data( map, key, other, exists )
!! Version: Experimental
!!
!! Change the other data associated with the key
!! Arguments:
!! map - the map with the entry of interest
!! key - the key to the entry inthe map
!! other - the new data to be associated with the key
!! exists - a logical flag indicating whether the key is already entered
!! in the map
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
class(*), intent(in) :: other
logical, intent(out), optional :: exists
integer(int_index) :: inmap
character(*), parameter :: procedure = 'SET_OTHER_DATA'
call in_chain_map( map, inmap, key )
if ( inmap <= 0 .or. inmap > size( map % inverse, kind=int_index ) ) &
then
if ( present(exists) ) then
exists = .false.
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
invalid_inmap
end if
else if ( associated( map % inverse(inmap) % target ) ) then
map % inverse(inmap) % target % other = other
if ( present(exists) ) exists = .true.
return
else
error stop submodule_name // ' % ' // procedure // ': ' // &
invalid_inmap
end if
end subroutine set_other_chaining_data
module function total_chaining_depth( map ) result(total_depth)
!! Version: Experimental
!!
!! Returns the total number of ones based offsets of slot entries from
!! their slot index for a hash map
!! Arguments:
!! map - an chaining hash map
class(chaining_hashmap_type), intent(in) :: map
integer(int_depth) :: total_depth
type(chaining_map_entry_type), pointer :: current_key
integer(int_index) :: slot, slots
integer(int_depth) :: index
total_depth = 0_int_depth
slots = size( map % slots, kind=int_index )
do slot=0, slots-1
current_key => map % slots(slot) % target
index = 0_int_depth
do while( associated(current_key) )
index = index + 1_int_depth
total_depth = total_depth + index
current_key => current_key % next
end do
end do
end function total_chaining_depth
module subroutine chaining_key_test(map, key, present)
!! Version: Experimental
!!
!! Returns a logical flag indicating whether KEY is present in the hash map
!! Arguments:
!! map - the hash map of interest
!! key - the key of interest
!! present - a logical flag indicating whether key is present in map
!
class(chaining_hashmap_type), intent(inout) :: map
type(key_type), intent(in) :: key
logical, intent(out) :: present
integer(int_index) :: inmap
call in_chain_map( map, inmap, key )
if ( inmap <= 0 .or. inmap > size( map % inverse, kind=int_index ) ) &
then
present = .false.
else
present = associated( map % inverse(inmap) % target )
end if
end subroutine chaining_key_test
end submodule stdlib_hashmap_chaining
fortran-lang-stdlib-0ede301/src/hashmaps/CMakeLists.txt 0000664 0001750 0001750 00000000450 15135654166 023320 0 ustar alastair alastair set(hashmaps_f90Files
stdlib_hashmap_chaining.f90
stdlib_hashmap_open.f90
stdlib_hashmaps.f90
stdlib_hashmap_wrappers.f90
)
configure_stdlib_target(${PROJECT_NAME}_hashmaps hashmaps_f90Files "" "")
target_link_libraries(${PROJECT_NAME}_hashmaps PUBLIC ${PROJECT_NAME}_hash)
fortran-lang-stdlib-0ede301/src/hashmaps/stdlib_hashmap_wrappers.f90 0000664 0001750 0001750 00000024663 15135654166 026021 0 ustar alastair alastair !! The module STDLIB_HASHMAP_WRAPPERS provides wrappers for various
!! entities used by the hash map procedures. These include wrappers for the
!! `key` and `other` data, and hashing procedures to operate on entities of
!! the `key_type`.
module stdlib_hashmap_wrappers
use, intrinsic :: iso_fortran_env, only : &
character_storage_size
use stdlib_hash_32bit
use stdlib_kinds, only : &
int8, &
int16, &
int32, &
int64, &
dp
implicit none
private
!! Public procedures
public :: &
copy_key, &
fibonacci_hash, &
fnv_1_hasher, &
fnv_1a_hasher, &
free_key, &
get, &
hasher_fun, &
operator(==), &
seeded_nmhash32_hasher, &
seeded_nmhash32x_hasher, &
seeded_water_hasher, &
set
!! Public types
public :: &
key_type
!! Public integers
public :: &
int_hash
integer, parameter :: &
! Should be 8
bits_int8 = bit_size(0_int8)
integer, parameter :: &
bits_char = character_storage_size, &
bytes_char = bits_char/bits_int8
character(*), parameter :: module_name = "STDLIB_HASHMAP_WRAPPERS"
type :: key_type
!! Version: Experimental
!!
!! A wrapper type for the key's true type
! private
integer(int8), allocatable :: value(:)
end type key_type
abstract interface
!! Version: Experimental
!!
!! Abstract interface to a 64 bit hash function operating on a KEY_TYPE
pure function hasher_fun( key ) result(hash_value)
import key_type, int_hash
type(key_type), intent(in) :: key
integer(int_hash) :: hash_value
end function hasher_fun
end interface
interface get
module procedure get_char_key, &
get_int8_key, &
get_int32_key
end interface get
interface operator(==)
module procedure equal_keys
end interface operator(==)
interface set
module procedure set_char_key, &
set_int8_key, &
set_int32_key
end interface set
contains
pure subroutine copy_key( old_key, new_key )
!! Version: Experimental
!!
!! Copies the contents of the key, old_key, to the key, new_key
!! ([Specifications](../page/specs/stdlib_hashmaps.html#copy_key-returns-a-copy-of-the-key))
!!
!! Arguments:
!! old_key - the input key
!! new_key - the output copy of old_key
type(key_type), intent(in) :: old_key
type(key_type), intent(out) :: new_key
new_key % value = old_key % value
end subroutine copy_key
function equal_keys( key1, key2 ) result(test) ! Chase's tester
!! Version: Experimental
!!
!! Compares two keys for equality
!! ([Specifications](../page/specs/stdlib_hashmaps.html#operator(==)-compares-two-keys-for-equality))
!!
!! Arguments:
!! key1 - the first key
!! key2 - the second key
logical :: test
type(key_type), intent(in) :: key1
type(key_type), intent(in) :: key2
if ( size(key1 % value, kind=int64) /= &
size(key2 % value, kind=int64) ) then
test = .false.
return
end if
if ( all( key1 % value == key2 % value ) ) then
test = .true.
else
test = .false.
end if
end function equal_keys
subroutine free_key( key )
!! Version: Experimental
!!
!! Frees the memory in a key
!! ([Specifications](../page/specs/stdlib_hashmaps.html#free_key-frees-the-memory-associated-with-a-key))
!!
!! Arguments:
!! key - the key
type(key_type), intent(inout) :: key
if ( allocated( key % value ) ) deallocate( key % value )
end subroutine free_key
subroutine get_char_key( key, value )
!! Version: Experimental
!!
!! Gets the contents of the key as a CHARACTER string
!! Arguments:
!! key - the input key
!! value - the contents of key mapped to a CHARACTER string
type(key_type), intent(in) :: key
character(:), allocatable, intent(out) :: value
character(*), parameter :: procedure = "GET"
integer(int64) :: key_as_char
integer(int64) :: key_size
key_size = size( key % value, kind=int64 )
select case( bytes_char )
case(1)
key_as_char = key_size
case(2)
if ( iand( key_size, 1_int64 ) > 0 ) then
error stop module_name // " % " // procedure // &
": Internal Error at stdlib_hashmaps: " // &
"System uses 2 bytes per character, so " // &
"key_size can't be an odd number."
end if
key_as_char = ishft( key_size, -1 )
case(4)
if ( iand( key_size, 3_int64) > 0 ) then
error stop module_name // " % " // procedure // &
": Internal Error at stdlib_hashmaps: " // &
"System uses 4 bytes per character, and " // &
"key_size is not a multiple of four."
end if
key_as_char = ishft( key_size, -2 )
case default
error stop module_name // " % " // procedure // &
": Internal Error: " // &
"System doesn't use a power of two for its " // &
"character size as expected by stdlib_hashmaps."
end select
allocate( character( len=key_as_char ) :: value )
value(1:key_as_char) = transfer( key % value, value )
end subroutine get_char_key
subroutine get_int8_key( key, value )
!! Version: Experimental
!!
!! Gets the contents of the key as an INTEGER(INT8) vector
!! Arguments:
!! key - the input key
!! value - the contents of key mapped to an INTEGER(INT8) vector
type(key_type), intent(in) :: key
integer(int8), allocatable, intent(out) :: value(:)
value = key % value
end subroutine get_int8_key
pure subroutine get_int32_key( key, value )
!! Version: Experimental
!!
!! Gets the contents of the key as an INTEGER(INT32) vector
!! Arguments:
!! key - the input key
!! value - the contents of key mapped to an INTEGER(INT32) vector
type(key_type), intent(in) :: key
integer(int32), allocatable, intent(out) :: value(:)
value = transfer( key % value, value )
end subroutine get_int32_key
subroutine set_char_key( key, value )
!! Version: Experimental
!!
!! Sets the contents of the key from a CHARACTER string
!! Arguments:
!! key - the output key
!! value - the input CHARACTER string
type(key_type), intent(out) :: key
character(*), intent(in) :: value
key % value = transfer( value, key % value, &
bytes_char * len( value ) )
end subroutine set_char_key
subroutine set_int8_key( key, value )
!! Version: Experimental
!!
!! Sets the contents of the key from an INTEGER(INT8) vector
!! Arguments:
!! key - the output key
!! value - the input INTEGER(INT8) vector
type(key_type), intent(out) :: key
integer(int8), intent(in) :: value(:)
key % value = value
end subroutine set_int8_key
pure subroutine set_int32_key( key, value )
!! Version: Experimental
!!
!! Sets the contents of the key from an INTEGER(INT32) vector
!! Arguments:
!! key - the output key
!! value - the input INTEGER(INT32) vector
type(key_type), intent(out) :: key
integer(int32), intent(in) :: value(:)
key % value = transfer(value, key % value)
end subroutine set_int32_key
pure function fnv_1_hasher( key )
!! Version: Experimental
!!
!! Hashes a key with the FNV_1 algorithm
!! Arguments:
!! key - the key to be hashed
type(key_type), intent(in) :: key
integer(int_hash) :: fnv_1_hasher
fnv_1_hasher = fnv_1_hash( key % value )
end function fnv_1_hasher
pure function fnv_1a_hasher( key )
!! Version: Experimental
!!
!! Hashes a key with the FNV_1a algorithm
!! ([Specifications](../page/specs/stdlib_hashmaps.html#fnv_1a_hasher-calculates-a-hash-code-from-a-key))
!!
!! Arguments:
!! key - the key to be hashed
type(key_type), intent(in) :: key
integer(int_hash) :: fnv_1a_hasher
fnv_1a_hasher = fnv_1a_hash( key % value )
end function fnv_1a_hasher
pure function seeded_nmhash32_hasher( key )
!! Version: Experimental
!!
!! Hashes a key with the NMHASH32 hash algorithm
!! ([Specifications](../page/specs/stdlib_hashmaps.html#seeded_nmhash32_hasher-calculates-a-hash-code-from-a-key))
!!
!! Arguments:
!! key - the key to be hashed
!! seed - the seed (unused) for the hashing algorithm
type(key_type), intent(in) :: key
integer(int_hash) :: seeded_nmhash32_hasher
seeded_nmhash32_hasher = nmhash32( key % value, &
int( z'DEADBEEF', int32 ) )
end function seeded_nmhash32_hasher
pure function seeded_nmhash32x_hasher( key )
!! Version: Experimental
!!
!! Hashes a key with the NMHASH32X hash algorithm
!! ([Specifications](../page/specs/stdlib_hashmaps.html#seeded_nmhash32x_hasher-calculates-a-hash-code-from-a-key))
!! Arguments:
!! key - the key to be hashed
!! seed - the seed (unused) for the hashing algorithm
type(key_type), intent(in) :: key
integer(int_hash) :: seeded_nmhash32x_hasher
seeded_nmhash32x_hasher = nmhash32x( key % value, &
int( z'DEADBEEF', int32 ) )
end function seeded_nmhash32x_hasher
pure function seeded_water_hasher( key )
!! Version: Experimental
!!
!! Hashes a key with the waterhash algorithm
!! ([Specifications](../page/specs/stdlib_hashmaps.html#seeded_water_hasher-calculates-a-hash-code-from-a-key))
!!
!! Arguments:
!! key - the key to be hashed
type(key_type), intent(in) :: key
integer(int_hash) :: seeded_water_hasher
seeded_water_hasher = water_hash( key % value, &
int( z'DEADBEEF1EADBEEF', int64 ) )
end function seeded_water_hasher
end module stdlib_hashmap_wrappers
fortran-lang-stdlib-0ede301/src/linalg_iterative/ 0000775 0001750 0001750 00000000000 15135654166 022277 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/linalg_iterative/stdlib_linalg_iterative_solvers.fypp 0000664 0001750 0001750 00000025527 15135654166 031652 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set MATRIX_TYPES = ["dense", "CSR"]
#:set RANKS = range(1, 2+1)
!! The `stdlib_linalg_iterative_solvers` module provides interfaces for iterative solvers.
!!
module stdlib_linalg_iterative_solvers
use stdlib_kinds
use stdlib_sparse
implicit none
private
!! workspace sizes: defined by the number of vectors used by the iterative solver.
enum, bind(c)
enumerator :: stdlib_size_wksp_cg = 3
enumerator :: stdlib_size_wksp_pcg = 4
enumerator :: stdlib_size_wksp_bicgstab = 8
end enum
public :: stdlib_size_wksp_cg, stdlib_size_wksp_pcg, stdlib_size_wksp_bicgstab
enum, bind(c)
enumerator :: pc_none = 0
enumerator :: pc_jacobi
end enum
public :: pc_none, pc_jacobi
!! version: experimental
!!
!! [Specifications](../page/specs/stdlib_linalg_iterative_solvers.html#stdlib_linop)
!!
!! linop type holding the linear operator and its associated methods.
!! The `linop` type is used to define the linear operator for the iterative solvers.
#:for k, t, s in R_KINDS_TYPES
type, public :: stdlib_linop_${s}$_type
procedure(vector_sub_${s}$), nopass, pointer :: matvec => null()
procedure(reduction_sub_${s}$), nopass, pointer :: inner_product => default_dot_${s}$
end type
#:endfor
!! version: experimental
!!
!! [Specifications](../page/specs/stdlib_linalg_iterative_solvers.html#stdlib_solver_workspace)
!!
!! solver_workspace type holding temporal array data for the iterative solvers.
#:for k, t, s in R_KINDS_TYPES
type, public :: stdlib_solver_workspace_${s}$_type
${t}$, allocatable :: tmp(:,:)
procedure(logger_sub_${s}$), pointer, nopass :: callback => null()
end type
#:endfor
abstract interface
#:for k, t, s in R_KINDS_TYPES
subroutine vector_sub_${s}$(x,y,alpha,beta,op)
import :: ${k}$
${t}$, intent(in) :: x(:)
${t}$, intent(inout) :: y(:)
${t}$, intent(in) :: alpha
${t}$, intent(in) :: beta
character(1), intent(in) :: op
end subroutine
${t}$ function reduction_sub_${s}$(x,y) result(r)
import :: ${k}$
${t}$, intent(in) :: x(:)
${t}$, intent(in) :: y(:)
end function
subroutine logger_sub_${s}$(x,norm_sq,iter)
import :: ${k}$
${t}$, intent(in) :: x(:)
${t}$, intent(in) :: norm_sq
integer, intent(in) :: iter
end subroutine
#:endfor
end interface
!! version: experimental
!!
!! stdlib_solve_cg_kernel interface for the conjugate gradient method.
!! [Specifications](../page/specs/stdlib_linalg_iterative_solvers.html#stdlib_solve_cg_kernel)
interface stdlib_solve_cg_kernel
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_cg_kernel_${s}$(A,b,x,rtol,atol,maxiter,workspace)
class(stdlib_linop_${s}$_type), intent(in) :: A !! linear operator
${t}$, intent(in) :: b(:) !! right-hand side vector
${t}$, intent(inout) :: x(:) !! solution vector and initial guess
${t}$, intent(in) :: rtol !! relative tolerance for convergence
${t}$, intent(in) :: atol !! absolut tolerance for convergence
integer, intent(in) :: maxiter !! maximum number of iterations
type(stdlib_solver_workspace_${s}$_type), intent(inout) :: workspace !! workspace for the solver
end subroutine
#:endfor
end interface
public :: stdlib_solve_cg_kernel
!! version: experimental
!!
!! [Specifications](../page/specs/stdlib_linalg_iterative_solvers.html#stdlib_solve_cg)
interface stdlib_solve_cg
#:for matrix in MATRIX_TYPES
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_cg_${matrix}$_${s}$(A,b,x,di,rtol,atol,maxiter,restart,workspace)
!! linear operator matrix
#:if matrix == "dense"
${t}$, intent(in) :: A(:,:)
#:else
type(${matrix}$_${s}$_type), intent(in) :: A
#:endif
${t}$, intent(in) :: b(:) !! right-hand side vector
${t}$, intent(inout) :: x(:) !! solution vector and initial guess
${t}$, intent(in), optional :: rtol !! relative tolerance for convergence
${t}$, intent(in), optional :: atol !! absolute tolerance for convergence
logical(int8), intent(in), optional, target :: di(:) !! dirichlet conditions mask
integer, intent(in), optional :: maxiter !! maximum number of iterations
logical, intent(in), optional :: restart !! restart flag
type(stdlib_solver_workspace_${s}$_type), optional, intent(inout), target :: workspace !! workspace for the solver
end subroutine
#:endfor
#:endfor
end interface
public :: stdlib_solve_cg
!! version: experimental
!!
!! stdlib_solve_pcg_kernel interface for the preconditionned conjugate gradient method.
!! [Specifications](../page/specs/stdlib_linalg_iterative_solvers.html#stdlib_solve_pcg_kernel)
interface stdlib_solve_pcg_kernel
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_pcg_kernel_${s}$(A,M,b,x,rtol,atol,maxiter,workspace)
class(stdlib_linop_${s}$_type), intent(in) :: A !! linear operator
class(stdlib_linop_${s}$_type), intent(in) :: M !! preconditioner linear operator
${t}$, intent(in) :: b(:) !! right-hand side vector
${t}$, intent(inout) :: x(:) !! solution vector and initial guess
${t}$, intent(in) :: rtol !! relative tolerance for convergence
${t}$, intent(in) :: atol !! absolute tolerance for convergence
integer, intent(in) :: maxiter !! maximum number of iterations
type(stdlib_solver_workspace_${s}$_type), intent(inout) :: workspace !! workspace for the solver
end subroutine
#:endfor
end interface
public :: stdlib_solve_pcg_kernel
!! version: experimental
!!
!! stdlib_solve_bicgstab_kernel interface for the biconjugate gradient stabilized method.
!! [Specifications](../page/specs/stdlib_linalg_iterative_solvers.html#stdlib_solve_bicgstab_kernel)
interface stdlib_solve_bicgstab_kernel
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_bicgstab_kernel_${s}$(A,M,b,x,rtol,atol,maxiter,workspace)
class(stdlib_linop_${s}$_type), intent(in) :: A !! linear operator
class(stdlib_linop_${s}$_type), intent(in) :: M !! preconditioner linear operator
${t}$, intent(in) :: b(:) !! right-hand side vector
${t}$, intent(inout) :: x(:) !! solution vector and initial guess
${t}$, intent(in) :: rtol !! relative tolerance for convergence
${t}$, intent(in) :: atol !! absolute tolerance for convergence
integer, intent(in) :: maxiter !! maximum number of iterations
type(stdlib_solver_workspace_${s}$_type), intent(inout) :: workspace !! workspace for the solver
end subroutine
#:endfor
end interface
public :: stdlib_solve_bicgstab_kernel
!! version: experimental
!!
!! [Specifications](../page/specs/stdlib_linalg_iterative_solvers.html#stdlib_solve_pcg)
interface stdlib_solve_pcg
#:for matrix in MATRIX_TYPES
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_pcg_${matrix}$_${s}$(A,b,x,di,rtol,atol,maxiter,restart,precond,M,workspace)
!! linear operator matrix
#:if matrix == "dense"
${t}$, intent(in) :: A(:,:)
#:else
type(${matrix}$_${s}$_type), intent(in) :: A
#:endif
${t}$, intent(in) :: b(:) !! right-hand side vector
${t}$, intent(inout) :: x(:) !! solution vector and initial guess
${t}$, intent(in), optional :: rtol !! relative tolerance for convergence
${t}$, intent(in), optional :: atol !! absolute tolerance for convergence
logical(int8), intent(in), optional, target :: di(:) !! dirichlet conditions mask
integer, intent(in), optional :: maxiter !! maximum number of iterations
logical, intent(in), optional :: restart !! restart flag
integer, intent(in), optional :: precond !! preconditioner method enumerator
class(stdlib_linop_${s}$_type), optional , intent(in), target :: M !! preconditioner linear operator
type(stdlib_solver_workspace_${s}$_type), optional, intent(inout), target :: workspace !! workspace for the solver
end subroutine
#:endfor
#:endfor
end interface
public :: stdlib_solve_pcg
!! version: experimental
!!
!! [Specifications](../page/specs/stdlib_linalg_iterative_solvers.html#stdlib_solve_bicgstab)
interface stdlib_solve_bicgstab
#:for matrix in MATRIX_TYPES
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_bicgstab_${matrix}$_${s}$(A,b,x,di,rtol,atol,maxiter,restart,precond,M,workspace)
!! linear operator matrix
#:if matrix == "dense"
${t}$, intent(in) :: A(:,:)
#:else
type(${matrix}$_${s}$_type), intent(in) :: A
#:endif
${t}$, intent(in) :: b(:) !! right-hand side vector
${t}$, intent(inout) :: x(:) !! solution vector and initial guess
${t}$, intent(in), optional :: rtol !! relative tolerance for convergence
${t}$, intent(in), optional :: atol !! absolute tolerance for convergence
logical(int8), intent(in), optional, target :: di(:) !! dirichlet conditions mask
integer, intent(in), optional :: maxiter !! maximum number of iterations
logical, intent(in), optional :: restart !! restart flag
integer, intent(in), optional :: precond !! preconditioner method enumerator
class(stdlib_linop_${s}$_type), optional , intent(in), target :: M !! preconditioner linear operator
type(stdlib_solver_workspace_${s}$_type), optional, intent(inout), target :: workspace !! workspace for the solver
end subroutine
#:endfor
#:endfor
end interface
public :: stdlib_solve_bicgstab
contains
!------------------------------------------------------------------
! defaults
!------------------------------------------------------------------
#:for k, t, s in R_KINDS_TYPES
${t}$ function default_dot_${s}$(x,y) result(r)
use stdlib_intrinsics, only: stdlib_dot_product
${t}$, intent(in) :: x(:)
${t}$, intent(in) :: y(:)
r = stdlib_dot_product(x,y)
end function
#:endfor
end module stdlib_linalg_iterative_solvers
fortran-lang-stdlib-0ede301/src/linalg_iterative/stdlib_linalg_iterative_solvers_pcg.fypp 0000664 0001750 0001750 00000017114 15135654166 032474 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set MATRIX_TYPES = ["dense", "CSR"]
#:set RANKS = range(1, 2+1)
submodule(stdlib_linalg_iterative_solvers) stdlib_linalg_iterative_pcg
use stdlib_kinds
use stdlib_sparse
use stdlib_constants
use stdlib_optval, only: optval
implicit none
contains
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_pcg_kernel_${s}$(A,M,b,x,rtol,atol,maxiter,workspace)
class(stdlib_linop_${s}$_type), intent(in) :: A
class(stdlib_linop_${s}$_type), intent(in) :: M
${t}$, intent(in) :: b(:), rtol, atol
${t}$, intent(inout) :: x(:)
integer, intent(in) :: maxiter
type(stdlib_solver_workspace_${s}$_type), intent(inout) :: workspace
!-------------------------
integer :: iter
${t}$ :: norm_sq, norm_sq0, norm_sq_old
${t}$ :: zr1, zr2, zv2, alpha, beta, tolsq
!-------------------------
iter = 0
associate( R => workspace%tmp(:,1), &
S => workspace%tmp(:,2), &
P => workspace%tmp(:,3), &
Q => workspace%tmp(:,4))
norm_sq = A%inner_product( b, b )
norm_sq0 = norm_sq
if(associated(workspace%callback)) call workspace%callback(x, norm_sq, iter)
if ( norm_sq0 > zero_${s}$ ) then
R = B
call A%matvec(X, R, alpha= -one_${s}$, beta=one_${s}$, op='N') ! R = B - A*X
call M%matvec(R,P, alpha= one_${s}$, beta=zero_${s}$, op='N') ! P = M^{-1}*R
tolsq = max(rtol*rtol * norm_sq0, atol*atol)
zr1 = zero_${s}$
zr2 = one_${s}$
do while ( (iter < maxiter) .AND. (norm_sq >= tolsq) )
call M%matvec(R,S, alpha= one_${s}$, beta=zero_${s}$, op='N') ! S = M^{-1}*R
zr2 = A%inner_product( R, S )
if (iter>0) then
beta = zr2 / zr1
P = S + beta * P
end if
call A%matvec(P, Q, alpha= one_${s}$, beta=zero_${s}$, op='N') ! Q = A*P
zv2 = A%inner_product( P, Q )
alpha = zr2 / zv2
X = X + alpha * P
R = R - alpha * Q
norm_sq = A%inner_product( R, R )
norm_sq_old = norm_sq
zr1 = zr2
iter = iter + 1
if(associated(workspace%callback)) call workspace%callback(x, norm_sq, iter)
end do
end if
end associate
end subroutine
#:endfor
#:for matrix in MATRIX_TYPES
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_pcg_${matrix}$_${s}$(A,b,x,di,rtol,atol,maxiter,restart,precond,M,workspace)
#:if matrix == "dense"
use stdlib_linalg, only: diag
${t}$, intent(in) :: A(:,:)
#:else
type(${matrix}$_${s}$_type), intent(in) :: A
#:endif
${t}$, intent(in) :: b(:)
${t}$, intent(inout) :: x(:)
${t}$, intent(in), optional :: rtol, atol
logical(int8), intent(in), optional, target :: di(:)
integer, intent(in), optional :: maxiter
logical, intent(in), optional :: restart
integer, intent(in), optional :: precond
class(stdlib_linop_${s}$_type), optional , intent(in), target :: M
type(stdlib_solver_workspace_${s}$_type), optional, intent(inout), target :: workspace
!-------------------------
type(stdlib_linop_${s}$_type) :: op
type(stdlib_linop_${s}$_type), pointer :: M_ => null()
type(stdlib_solver_workspace_${s}$_type), pointer :: workspace_
integer :: n, maxiter_
${t}$ :: rtol_, atol_
logical :: restart_
logical(int8), pointer :: di_(:)
!-------------------------
! working data for preconditioner
integer :: precond_
${t}$, allocatable :: diagonal(:)
!-------------------------
n = size(b)
maxiter_ = optval(x=maxiter, default=n)
restart_ = optval(x=restart, default=.true.)
rtol_ = optval(x=rtol, default=1.e-5_${s}$)
atol_ = optval(x=atol, default=epsilon(one_${s}$))
precond_ = optval(x=precond, default=pc_none)
!-------------------------
! internal memory setup
! preconditioner
if(present(M)) then
M_ => M
else
allocate( M_ )
allocate(diagonal(n),source=zero_${s}$)
select case(precond_)
case(pc_jacobi)
#:if matrix == "dense"
diagonal = diag(A)
#:else
call diag(A,diagonal)
#:endif
M_%matvec => precond_jacobi
case default
M_%matvec => precond_none
end select
where(abs(diagonal)>epsilon(zero_${s}$)) diagonal = one_${s}$/diagonal
end if
! matvec for the operator
op%matvec => matvec
! direchlet boundary conditions mask
if(present(di))then
di_ => di
else
allocate(di_(n),source=.false._int8)
end if
! workspace for the solver
if(present(workspace)) then
workspace_ => workspace
else
allocate( workspace_ )
end if
if(.not.allocated(workspace_%tmp)) allocate( workspace_%tmp(n,stdlib_size_wksp_pcg) , source = zero_${s}$ )
!-------------------------
! main call to the solver
if(restart_) x = zero_${s}$
x = merge( b, x, di_ ) ! copy dirichlet load conditions encoded in B and indicated by di
call stdlib_solve_pcg_kernel(op,M_,b,x,rtol_,atol_,maxiter_,workspace_)
!-------------------------
! internal memory cleanup
if(.not.present(di)) deallocate(di_)
di_ => null()
if(.not.present(workspace)) then
deallocate( workspace_%tmp )
deallocate( workspace_ )
end if
M_ => null()
workspace_ => null()
contains
subroutine matvec(x,y,alpha,beta,op)
#:if matrix == "dense"
use stdlib_linalg_blas, only: gemv
#:endif
${t}$, intent(in) :: x(:)
${t}$, intent(inout) :: y(:)
${t}$, intent(in) :: alpha
${t}$, intent(in) :: beta
character(1), intent(in) :: op
#:if matrix == "dense"
call gemv(op,m=size(A,1),n=size(A,2),alpha=alpha,a=A,lda=size(A,1),x=x,incx=1,beta=beta,y=y,incy=1)
#:else
call spmv( A , x, y , alpha, beta , op)
#:endif
y = merge( zero_${s}$, y, di_ )
end subroutine
subroutine precond_none(x,y,alpha,beta,op)
${t}$, intent(in) :: x(:)
${t}$, intent(inout) :: y(:)
${t}$, intent(in) :: alpha
${t}$, intent(in) :: beta
character(1), intent(in) :: op
y = merge( zero_${s}$, x, di_ )
end subroutine
subroutine precond_jacobi(x,y,alpha,beta,op)
${t}$, intent(in) :: x(:)
${t}$, intent(inout) :: y(:)
${t}$, intent(in) :: alpha
${t}$, intent(in) :: beta
character(1), intent(in) :: op
y = merge( zero_${s}$, diagonal * x, di_ ) ! inverted diagonal
end subroutine
end subroutine
#:endfor
#:endfor
end submodule stdlib_linalg_iterative_pcg fortran-lang-stdlib-0ede301/src/linalg_iterative/CMakeLists.txt 0000664 0001750 0001750 00000001031 15135654166 025032 0 ustar alastair alastair set(linalg_iterative_fppFiles
stdlib_linalg_iterative_solvers_bicgstab.fypp
stdlib_linalg_iterative_solvers_cg.fypp
stdlib_linalg_iterative_solvers.fypp
stdlib_linalg_iterative_solvers_pcg.fypp
)
set(linalg_iterative_cppFiles
)
set(linalg_iterative_f90Files
)
configure_stdlib_target(${PROJECT_NAME}_linalg_iterative linalg_iterative_f90Files linalg_iterative_fppFiles linalg_iterative_cppFiles)
target_link_libraries(${PROJECT_NAME}_linalg_iterative PUBLIC ${PROJECT_NAME}_linalg ${PROJECT_NAME}_sparse)
fortran-lang-stdlib-0ede301/src/linalg_iterative/stdlib_linalg_iterative_solvers_bicgstab.fypp 0000664 0001750 0001750 00000022332 15135654166 033477 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set MATRIX_TYPES = ["dense", "CSR"]
#:set RANKS = range(1, 2+1)
submodule(stdlib_linalg_iterative_solvers) stdlib_linalg_iterative_bicgstab
use stdlib_kinds
use stdlib_sparse
use stdlib_constants
use stdlib_optval, only: optval
implicit none
contains
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_bicgstab_kernel_${s}$(A,M,b,x,rtol,atol,maxiter,workspace)
class(stdlib_linop_${s}$_type), intent(in) :: A
class(stdlib_linop_${s}$_type), intent(in) :: M
${t}$, intent(in) :: b(:), rtol, atol
${t}$, intent(inout) :: x(:)
integer, intent(in) :: maxiter
type(stdlib_solver_workspace_${s}$_type), intent(inout) :: workspace
!-------------------------
integer :: iter
${t}$ :: norm_sq, norm_sq0, tolsq
${t}$ :: rho, rho_prev, alpha, beta, omega, rv
${t}$, parameter :: rhotol = epsilon(one_${s}$)**2
${t}$, parameter :: omegatol = epsilon(one_${s}$)**2
!-------------------------
iter = 0
associate( R => workspace%tmp(:,1), &
Rt => workspace%tmp(:,2), &
P => workspace%tmp(:,3), &
Pt => workspace%tmp(:,4), &
V => workspace%tmp(:,5), &
S => workspace%tmp(:,6), &
St => workspace%tmp(:,7), &
T => workspace%tmp(:,8))
norm_sq = A%inner_product( b, b )
norm_sq0 = norm_sq
if(associated(workspace%callback)) call workspace%callback(x, norm_sq, iter)
if ( norm_sq0 > zero_${s}$ ) then
! Compute initial residual: r = b - A*x
R = B
call A%matvec(X, R, alpha= -one_${s}$, beta=one_${s}$, op='N') ! R = B - A*X
! Choose arbitrary Rt (often Rt = r0)
Rt = R
tolsq = max(rtol*rtol * norm_sq0, atol*atol)
rho_prev = one_${s}$
alpha = one_${s}$
omega = one_${s}$
do while ( (iter < maxiter) .AND. (norm_sq >= tolsq) )
rho = A%inner_product( Rt, R )
! Check for rho breakdown
if (abs(rho) < rhotol) exit
if (iter > 0) then
! Check for omega breakdown
if (abs(omega) < omegatol) exit
beta = (rho / rho_prev) * (alpha / omega)
P = R + beta * (P - omega * V)
else
P = R
end if
! Preconditioned BiCGSTAB step
call M%matvec(P, Pt, alpha=one_${s}$, beta=zero_${s}$, op='N') ! Pt = M^{-1}*P
call A%matvec(Pt, V, alpha=one_${s}$, beta=zero_${s}$, op='N') ! V = A*Pt
rv = A%inner_product( Rt, V )
if (abs(rv) < epsilon(one_${s}$)) exit ! rv breakdown
alpha = rho / rv
! Update residual: s = r - alpha*v
S = R - alpha * V
! Check if s is small enough
norm_sq = A%inner_product( S, S )
if (norm_sq < tolsq) then
X = X + alpha * Pt
exit
end if
! Preconditioned update for t = A * M^{-1} * s
call M%matvec(S, St, alpha=one_${s}$, beta=zero_${s}$, op='N') ! St = M^{-1}*S
call A%matvec(St, T, alpha=one_${s}$, beta=zero_${s}$, op='N') ! T = A*St
! Compute omega
omega = A%inner_product( T, S ) / A%inner_product( T, T )
! Update solution and residual
X = X + alpha * Pt + omega * St
R = S - omega * T
norm_sq = A%inner_product( R, R )
rho_prev = rho
iter = iter + 1
if(associated(workspace%callback)) call workspace%callback(x, norm_sq, iter)
end do
end if
end associate
end subroutine
#:endfor
#:for matrix in MATRIX_TYPES
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_bicgstab_${matrix}$_${s}$(A,b,x,di,rtol,atol,maxiter,restart,precond,M,workspace)
#:if matrix == "dense"
use stdlib_linalg, only: diag
${t}$, intent(in) :: A(:,:)
#:else
type(${matrix}$_${s}$_type), intent(in) :: A
#:endif
${t}$, intent(in) :: b(:)
${t}$, intent(inout) :: x(:)
${t}$, intent(in), optional :: rtol, atol
logical(int8), intent(in), optional, target :: di(:)
integer, intent(in), optional :: maxiter
logical, intent(in), optional :: restart
integer, intent(in), optional :: precond
class(stdlib_linop_${s}$_type), optional , intent(in), target :: M
type(stdlib_solver_workspace_${s}$_type), optional, intent(inout), target :: workspace
!-------------------------
type(stdlib_linop_${s}$_type) :: op
type(stdlib_linop_${s}$_type), pointer :: M_ => null()
type(stdlib_solver_workspace_${s}$_type), pointer :: workspace_
integer :: n, maxiter_
${t}$ :: rtol_, atol_
logical :: restart_
logical(int8), pointer :: di_(:)
!-------------------------
! working data for preconditioner
integer :: precond_
${t}$, allocatable :: diagonal(:)
!-------------------------
n = size(b)
maxiter_ = optval(x=maxiter, default=n)
restart_ = optval(x=restart, default=.true.)
rtol_ = optval(x=rtol, default=1.e-5_${s}$)
atol_ = optval(x=atol, default=epsilon(one_${s}$))
precond_ = optval(x=precond, default=pc_none)
!-------------------------
! internal memory setup
! preconditioner
if(present(M)) then
M_ => M
else
allocate( M_ )
allocate(diagonal(n),source=zero_${s}$)
select case(precond_)
case(pc_jacobi)
#:if matrix == "dense"
diagonal = diag(A)
#:else
call diag(A,diagonal)
#:endif
M_%matvec => precond_jacobi
case default
M_%matvec => precond_none
end select
where(abs(diagonal)>epsilon(zero_${s}$)) diagonal = one_${s}$/diagonal
end if
! matvec for the operator
op%matvec => matvec
! direchlet boundary conditions mask
if(present(di))then
di_ => di
else
allocate(di_(n),source=.false._int8)
end if
! workspace for the solver
if(present(workspace)) then
workspace_ => workspace
else
allocate( workspace_ )
end if
if(.not.allocated(workspace_%tmp)) allocate( workspace_%tmp(n,stdlib_size_wksp_bicgstab) , source = zero_${s}$ )
!-------------------------
! main call to the solver
if(restart_) x = zero_${s}$
x = merge( b, x, di_ ) ! copy dirichlet load conditions encoded in B and indicated by di
call stdlib_solve_bicgstab_kernel(op,M_,b,x,rtol_,atol_,maxiter_,workspace_)
!-------------------------
! internal memory cleanup
if(.not.present(di)) deallocate(di_)
di_ => null()
if(.not.present(workspace)) then
deallocate( workspace_%tmp )
deallocate( workspace_ )
end if
M_ => null()
workspace_ => null()
contains
subroutine matvec(x,y,alpha,beta,op)
#:if matrix == "dense"
use stdlib_linalg_blas, only: gemv
#:endif
${t}$, intent(in) :: x(:)
${t}$, intent(inout) :: y(:)
${t}$, intent(in) :: alpha
${t}$, intent(in) :: beta
character(1), intent(in) :: op
#:if matrix == "dense"
call gemv(op,m=size(A,1),n=size(A,2),alpha=alpha,a=A,lda=size(A,1),x=x,incx=1,beta=beta,y=y,incy=1)
#:else
call spmv( A , x, y , alpha, beta , op)
#:endif
y = merge( zero_${s}$, y, di_ )
end subroutine
subroutine precond_none(x,y,alpha,beta,op)
${t}$, intent(in) :: x(:)
${t}$, intent(inout) :: y(:)
${t}$, intent(in) :: alpha
${t}$, intent(in) :: beta
character(1), intent(in) :: op
y = merge( zero_${s}$, x, di_ )
end subroutine
subroutine precond_jacobi(x,y,alpha,beta,op)
${t}$, intent(in) :: x(:)
${t}$, intent(inout) :: y(:)
${t}$, intent(in) :: alpha
${t}$, intent(in) :: beta
character(1), intent(in) :: op
y = merge( zero_${s}$, diagonal * x, di_ ) ! inverted diagonal
end subroutine
end subroutine
#:endfor
#:endfor
end submodule stdlib_linalg_iterative_bicgstab
fortran-lang-stdlib-0ede301/src/linalg_iterative/stdlib_linalg_iterative_solvers_cg.fypp 0000664 0001750 0001750 00000012541 15135654166 032313 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set MATRIX_TYPES = ["dense", "CSR"]
#:set RANKS = range(1, 2+1)
submodule(stdlib_linalg_iterative_solvers) stdlib_linalg_iterative_cg
use stdlib_kinds
use stdlib_sparse
use stdlib_constants
use stdlib_optval, only: optval
implicit none
contains
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_cg_kernel_${s}$(A,b,x,rtol,atol,maxiter,workspace)
class(stdlib_linop_${s}$_type), intent(in) :: A
${t}$, intent(in) :: b(:), rtol, atol
${t}$, intent(inout) :: x(:)
integer, intent(in) :: maxiter
type(stdlib_solver_workspace_${s}$_type), intent(inout) :: workspace
!-------------------------
integer :: iter
${t}$ :: norm_sq, norm_sq_old, norm_sq0
${t}$ :: alpha, beta, tolsq
!-------------------------
iter = 0
associate( P => workspace%tmp(:,1), &
R => workspace%tmp(:,2), &
Ap => workspace%tmp(:,3))
norm_sq0 = A%inner_product(B, B)
if(associated(workspace%callback)) call workspace%callback(x, norm_sq0, iter)
R = B
call A%matvec(X, R, alpha= -one_${s}$, beta=one_${s}$, op='N') ! R = B - A*X
norm_sq = A%inner_product(R, R)
P = R
tolsq = max(rtol*rtol * norm_sq0, atol*atol)
beta = zero_${s}$
if(associated(workspace%callback)) call workspace%callback(x, norm_sq, iter)
do while( norm_sq >= tolsq .and. iter < maxiter)
call A%matvec(P,Ap, alpha= one_${s}$, beta=zero_${s}$, op='N') ! Ap = A*P
alpha = norm_sq / A%inner_product(P, Ap)
X = X + alpha * P
R = R - alpha * Ap
norm_sq_old = norm_sq
norm_sq = A%inner_product(R, R)
beta = norm_sq / norm_sq_old
P = R + beta * P
iter = iter + 1
if(associated(workspace%callback)) call workspace%callback(x, norm_sq, iter)
end do
end associate
end subroutine
#:endfor
#:for matrix in MATRIX_TYPES
#:for k, t, s in R_KINDS_TYPES
module subroutine stdlib_solve_cg_${matrix}$_${s}$(A,b,x,di,rtol,atol,maxiter,restart,workspace)
#:if matrix == "dense"
${t}$, intent(in) :: A(:,:)
#:else
type(${matrix}$_${s}$_type), intent(in) :: A
#:endif
${t}$, intent(in) :: b(:)
${t}$, intent(inout) :: x(:)
${t}$, intent(in), optional :: rtol, atol
logical(int8), intent(in), optional, target :: di(:)
integer, intent(in), optional :: maxiter
logical, intent(in), optional :: restart
type(stdlib_solver_workspace_${s}$_type), optional, intent(inout), target :: workspace
!-------------------------
type(stdlib_linop_${s}$_type) :: op
type(stdlib_solver_workspace_${s}$_type), pointer :: workspace_
integer :: n, maxiter_
${t}$ :: rtol_, atol_
logical :: restart_
logical(int8), pointer :: di_(:)
!-------------------------
n = size(b)
maxiter_ = optval(x=maxiter, default=n)
restart_ = optval(x=restart, default=.true.)
rtol_ = optval(x=rtol, default=1.e-5_${s}$)
atol_ = optval(x=atol, default=epsilon(one_${s}$))
!-------------------------
! internal memory setup
op%matvec => matvec
! op%inner_product => default_dot
if(present(di))then
di_ => di
else
allocate(di_(n),source=.false._int8)
end if
if(present(workspace)) then
workspace_ => workspace
else
allocate( workspace_ )
end if
if(.not.allocated(workspace_%tmp)) allocate( workspace_%tmp(n,stdlib_size_wksp_cg), source = zero_${s}$ )
!-------------------------
! main call to the solver
if(restart_) x = zero_${s}$
x = merge( b, x, di_ ) ! copy dirichlet load conditions encoded in B and indicated by di
call stdlib_solve_cg_kernel(op,b,x,rtol_,atol_,maxiter_,workspace_)
!-------------------------
! internal memory cleanup
if(.not.present(di)) deallocate(di_)
di_ => null()
if(.not.present(workspace)) then
deallocate( workspace_%tmp )
deallocate( workspace_ )
end if
workspace_ => null()
contains
subroutine matvec(x,y,alpha,beta,op)
#:if matrix == "dense"
use stdlib_linalg_blas, only: gemv
#:endif
${t}$, intent(in) :: x(:)
${t}$, intent(inout) :: y(:)
${t}$, intent(in) :: alpha
${t}$, intent(in) :: beta
character(1), intent(in) :: op
#:if matrix == "dense"
call gemv(op,m=size(A,1),n=size(A,2),alpha=alpha,a=A,lda=size(A,1),x=x,incx=1,beta=beta,y=y,incy=1)
#:else
call spmv( A , x, y , alpha, beta , op)
#:endif
y = merge( zero_${s}$, y, di_ )
end subroutine
end subroutine
#:endfor
#:endfor
end submodule stdlib_linalg_iterative_cg fortran-lang-stdlib-0ede301/src/sorting/ 0000775 0001750 0001750 00000000000 15135654166 020442 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/sorting/stdlib_sorting_sort_adjoint.fypp 0000664 0001750 0001750 00000051213 15135654166 027151 0 ustar alastair alastair #include "macros.inc"
#:include "common.fypp"
#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_TYPES, INT_KINDS, INT_CPPS))
#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_TYPES, REAL_KINDS, REAL_CPPS))
#:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_TYPES, STRING_KINDS, STRING_CPPS))
#:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=:)"], ["character(len=len(array))"], ["char"], [""]))
#:set BITSETS_TYPES_ALT_NAME = list(zip(BITSETS_TYPES, BITSETS_TYPES, BITSETS_TYPES, BITSETS_KINDS, BITSETS_CPPS))
#! For better code reuse in fypp, make lists that contain the input types,
#! with each having output types and a separate name prefix for subroutines
#! This approach allows us to have the same code for all input types.
#:set IRSCB_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME &
& + BITSETS_TYPES_ALT_NAME
#:set IR_INDEX_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME
!! Licensing:
!!
!! This file is subjec† both to the Fortran Standard Library license, and
!! to additional licensing requirements as it contains translations of
!! other software.
!!
!! The Fortran Standard Library, including this file, is distributed under
!! the MIT license that should be included with the library's distribution.
!!
!! Copyright (c) 2021 Fortran stdlib developers
!!
!! 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 sellcopies 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.
!!
!! 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.
!!
!! The generic subroutine, `SORT_ADJ`, is substantially a translation to
!! Fortran 2008 of the `"Rust" sort` sorting routines in
!! [`slice.rs`](https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs)
!! The `rust sort` implementation is distributed with the header:
!!
!! Copyright 2012-2015 The Rust Project Developers. See the COPYRIGHT
!! file at the top-level directory of this distribution and at
!! http://rust-lang.org/COPYRIGHT.
!!
!! Licensed under the Apache License, Version 2.0 or the MIT license
!! , at your
!! option. This file may not be copied, modified, or distributed
!! except according to those terms.
!!
!! so the license for the original`slice.rs` code is compatible with the use
!! of modified versions of the code in the Fortran Standard Library under
!! the MIT license.
submodule(stdlib_sorting) stdlib_sorting_sort_adjoint
implicit none
contains
#:for ki, ti, tii, namei, cppi in IR_INDEX_TYPES_ALT_NAME
#:for t1, t2, t3, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
module subroutine ${name1}$_${namei}$_sort_adjoint( array, adjoint_array, work, iwork, reverse )
! A modification of `${name1}$_ord_sort` to return an array of indices that
! would perform a stable sort of the `ARRAY` as input, and also sort `ARRAY`
! as desired. The indices by default
! correspond to a non-decreasing sort, but if the optional argument
! `REVERSE` is present with a value of `.TRUE.` the indices correspond to
! a non-increasing sort. The logic of the determination of indexing largely
! follows the `"Rust" sort` found in `slice.rs`:
! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159
! The Rust version in turn is a simplification of the Timsort algorithm
! described in
! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as
! it drops both the use of 'galloping' to identify bounds of regions to be
! sorted and the estimation of the optimal `run size`. However it remains
! a hybrid sorting algorithm combining an iterative Merge sort controlled
! by a stack of `RUNS` identified by regions of uniformly decreasing or
! non-decreasing sequences that may be expanded to a minimum run size and
! initially processed by an insertion sort.
!
! Note the Fortran implementation simplifies the logic as it only has to
! deal with Fortran arrays of intrinsic types and not the full generality
! of Rust's arrays and lists for arbitrary types. It also adds the
! estimation of the optimal `run size` as suggested in Tim Peters'
! original `listsort.txt`, and the optional `work` and `iwork` arrays to be
! used as scratch memory.
${t1}$, intent(inout) :: array(0:)
${ti}$, intent(inout) :: adjoint_array(0:)
${t3}$, intent(out), optional :: work(0:)
${ti}$, intent(out), optional :: iwork(0:)
logical, intent(in), optional :: reverse
${t2}$, allocatable :: buf(:)
${ti}$, allocatable :: ibuf(:)
integer(int_index) :: array_size
integer(int_index) :: stat
array_size = size(array, kind=int_index)
if ( optval(reverse, .false.) ) then
call reverse_segment( array, adjoint_array )
end if
! If necessary allocate buffers to serve as scratch memory.
if ( present(work) ) then
if ( size(work, kind=int_index) < array_size/2 ) then
error stop "work array is too small."
end if
if ( present(iwork) ) then
if ( size(iwork, kind=int_index) < array_size/2 ) then
error stop "iwork array is too small."
endif
call merge_sort( array, adjoint_array, work, iwork )
else
allocate( ibuf(0:array_size/2-1), stat=stat )
if ( stat /= 0 ) error stop "Allocation of adjoint_array buffer failed."
call merge_sort( array, adjoint_array, work, ibuf )
end if
else
! Allocate a buffer to use as scratch memory.
#:if t1[0:4] == "char"
allocate( ${t3}$ :: buf(0:array_size/2-1), &
stat=stat )
#:else
allocate( buf(0:array_size/2-1), stat=stat )
#:endif
if ( stat /= 0 ) error stop "Allocation of array buffer failed."
if ( present(iwork) ) then
if ( size(iwork, kind=int_index) < array_size/2 ) then
error stop "iwork array is too small."
endif
call merge_sort( array, adjoint_array, buf, iwork )
else
allocate( ibuf(0:array_size/2-1), stat=stat )
if ( stat /= 0 ) error stop "Allocation of adjoint_array buffer failed."
call merge_sort( array, adjoint_array, buf, ibuf )
end if
end if
if ( optval(reverse, .false.) ) then
call reverse_segment( array, adjoint_array )
end if
contains
pure function calc_min_run( n ) result(min_run)
!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is
!! less than or equal to a power of two. See
!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt
integer(int_index) :: min_run
integer(int_index), intent(in) :: n
integer(int_index) :: num, r
num = n
r = 0_int_index
do while( num >= 64 )
r = ior( r, iand(num, 1_int_index) )
num = ishft(num, -1_int_index)
end do
min_run = num + r
end function calc_min_run
pure subroutine insertion_sort( array, adjoint_array )
! Sorts `ARRAY` using an insertion sort, while maintaining consistency in
! location of the indices in `INDEX` to the elements of `ARRAY`.
${t1}$, intent(inout) :: array(0:)
${ti}$, intent(inout) :: adjoint_array(0:)
integer(int_index) :: i, j
${ti}$ :: key_adjoint_array
${t3}$ :: key
do j=1, size(array, kind=int_index)-1
key = array(j)
key_adjoint_array = adjoint_array(j)
i = j - 1
do while( i >= 0 )
if ( array(i) <= key ) exit
array(i+1) = array(i)
adjoint_array(i+1) = adjoint_array(i)
i = i - 1
end do
array(i+1) = key
adjoint_array(i+1) = key_adjoint_array
end do
end subroutine insertion_sort
pure function collapse( runs ) result ( r )
! Examine the stack of runs waiting to be merged, identifying adjacent runs
! to be merged until the stack invariants are restablished:
!
! 1. len(-3) > len(-2) + len(-1)
! 2. len(-2) > len(-1)
integer(int_index) :: r
type(run_type), intent(in), target :: runs(0:)
integer(int_index) :: n
logical :: test
n = size(runs, kind=int_index)
test = .false.
if (n >= 2) then
if ( runs( n-1 ) % base == 0 .or. &
runs( n-2 ) % len <= runs(n-1) % len ) then
test = .true.
else if ( n >= 3 ) then ! X exists
if ( runs(n-3) % len <= &
runs(n-2) % len + runs(n-1) % len ) then
test = .true.
! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2
else if( n >= 4 ) then
if ( runs(n-4) % len <= &
runs(n-3) % len + runs(n-2) % len ) then
test = .true.
! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3
end if
end if
end if
end if
if ( test ) then
! By default merge Y & Z, rho2 or rho3
if ( n >= 3 ) then
if ( runs(n-3) % len < runs(n-1) % len ) then
r = n - 3
! |X| < |Z| => merge X & Y, rho1
return
end if
end if
r = n - 2
! |Y| <= |Z| => merge Y & Z, rho4
return
else
r = -1
end if
end function collapse
pure subroutine insert_head( array, adjoint_array )
! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the
! whole `array(0:)` becomes sorted, copying the first element into
! a temporary variable, iterating until the right place for it is found.
! copying every traversed element into the slot preceding it, and finally,
! copying data from the temporary variable into the resulting hole.
! Consistency of the indices in `adjoint_array` with the elements of `array`
! are maintained.
${t1}$, intent(inout) :: array(0:)
${ti}$, intent(inout) :: adjoint_array(0:)
${t3}$ :: tmp
integer(int_index) :: i
${ti}$ :: tmp_adjoint_array
tmp = array(0)
tmp_adjoint_array = adjoint_array(0)
find_hole: do i=1, size(array, kind=int_index)-1
if ( array(i) >= tmp ) exit find_hole
array(i-1) = array(i)
adjoint_array(i-1) = adjoint_array(i)
end do find_hole
array(i-1) = tmp
adjoint_array(i-1) = tmp_adjoint_array
end subroutine insert_head
subroutine merge_sort( array, adjoint_array, buf, ibuf )
! The Rust merge sort borrows some (but not all) of the ideas from TimSort,
! which is described in detail at
! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt).
!
! The algorithm identifies strictly descending and non-descending
! subsequences, which are called natural runs. Where these runs are less
! than a minimum run size they are padded by adding additional samples
! using an insertion sort. The merge process is driven by a stack of
! pending unmerged runs. Each newly found run is pushed onto the stack,
! and then pairs of adjacentd runs are merged until these two invariants
! are satisfied:
!
! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len`
! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len >
! runs(i - 1)%len + runs(i)%len`
!
! The invariants ensure that the total running time is `O(n log n)`
! worst-case. Consistency of the indices in `adjoint_array` with the elements of
! `array` are maintained.
${t1}$, intent(inout) :: array(0:)
${ti}$, intent(inout) :: adjoint_array(0:)
${t3}$, intent(inout) :: buf(0:)
${ti}$, intent(inout) :: ibuf(0:)
integer(int_index) :: array_size, finish, min_run, r, r_count, &
start
type(run_type) :: runs(0:max_merge_stack-1), left, right
array_size = size(array, kind=int_index)
! Very short runs are extended using insertion sort to span at least this
! many elements. Slices of up to this length are sorted using insertion sort.
min_run = calc_min_run( array_size )
if ( array_size <= min_run ) then
if ( array_size >= 2 ) call insertion_sort( array, adjoint_array )
return
end if
! Following Rust sort, natural runs in `array` are identified by traversing
! it backwards. By traversing it backward, merges more often go in the
! opposite direction (forwards). According to developers of Rust sort,
! merging forwards is slightly faster than merging backwards. Therefore
! identifying runs by traversing backwards should improve performance.
r_count = 0
finish = array_size - 1
do while ( finish >= 0 )
! Find the next natural run, and reverse it if it's strictly descending.
start = finish
if ( start > 0 ) then
start = start - 1
if ( array(start+1) < array(start) ) then
Descending: do while ( start > 0 )
if ( array(start) >= array(start-1) ) &
exit Descending
start = start - 1
end do Descending
call reverse_segment( array(start:finish), &
adjoint_array(start:finish) )
else
Ascending: do while( start > 0 )
if ( array(start) < array(start-1) ) exit Ascending
start = start - 1
end do Ascending
end if
end if
! If the run is too short insert some more elements using an insertion sort.
Insert: do while ( start > 0 )
if ( finish - start >= min_run - 1 ) exit Insert
start = start - 1
call insert_head( array(start:finish), adjoint_array(start:finish) )
end do Insert
if ( start == 0 .and. finish == array_size - 1 ) return
runs(r_count) = run_type( base = start, &
len = finish - start + 1 )
finish = start-1
r_count = r_count + 1
! Determine whether pairs of adjacent runs need to be merged to satisfy
! the invariants, and, if so, merge them.
Merge_loop: do
r = collapse( runs(0:r_count - 1) )
if ( r < 0 .or. r_count <= 1 ) exit Merge_loop
left = runs( r + 1 )
right = runs( r )
call merge( array( left % base: &
right % base + right % len - 1 ), &
left % len, buf, &
adjoint_array( left % base: &
right % base + right % len - 1 ), ibuf )
runs(r) = run_type( base = left % base, &
len = left % len + right % len )
if ( r == r_count - 3 ) runs(r+1) = runs(r+2)
r_count = r_count - 1
end do Merge_loop
end do
if ( r_count /= 1 ) &
error stop "MERGE_SORT completed without RUN COUNT == 1."
end subroutine merge_sort
pure subroutine merge( array, mid, buf, adjoint_array, ibuf )
! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)`
! using `BUF` as temporary storage, and stores the merged runs into
! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF`
! must be long enough to hold the shorter of the two runs.
${t1}$, intent(inout) :: array(0:)
integer(int_index), intent(in) :: mid
${t3}$, intent(inout) :: buf(0:)
${ti}$, intent(inout) :: adjoint_array(0:)
${ti}$, intent(inout) :: ibuf(0:)
integer(int_index) :: array_len, i, j, k
array_len = size(array, kind=int_index)
! Merge first copies the shorter run into `buf`. Then, depending on which
! run was shorter, it traces the copied run and the longer run forwards
! (or backwards), comparing their next unprocessed elements and then
! copying the lesser (or greater) one into `array`.
if ( mid <= array_len - mid ) then ! The left run is shorter.
buf(0:mid-1) = array(0:mid-1)
ibuf(0:mid-1) = adjoint_array(0:mid-1)
i = 0
j = mid
merge_lower: do k = 0, array_len-1
if ( buf(i) <= array(j) ) then
array(k) = buf(i)
adjoint_array(k) = ibuf(i)
i = i + 1
if ( i >= mid ) exit merge_lower
else
array(k) = array(j)
adjoint_array(k) = adjoint_array(j)
j = j + 1
if ( j >= array_len ) then
array(k+1:) = buf(i:mid-1)
adjoint_array(k+1:) = ibuf(i:mid-1)
exit merge_lower
end if
end if
end do merge_lower
else ! The right run is shorter
buf(0:array_len-mid-1) = array(mid:array_len-1)
ibuf(0:array_len-mid-1) = adjoint_array(mid:array_len-1)
i = mid - 1
j = array_len - mid -1
merge_upper: do k = array_len-1, 0, -1
if ( buf(j) >= array(i) ) then
array(k) = buf(j)
adjoint_array(k) = ibuf(j)
j = j - 1
if ( j < 0 ) exit merge_upper
else
array(k) = array(i)
adjoint_array(k) = adjoint_array(i)
i = i - 1
if ( i < 0 ) then
array(0:k-1) = buf(0:j)
adjoint_array(0:k-1) = ibuf(0:j)
exit merge_upper
end if
end if
end do merge_upper
end if
end subroutine merge
pure subroutine reverse_segment( array, adjoint_array )
! Reverse a segment of an array in place
${t1}$, intent(inout) :: array(0:)
${ti}$, intent(inout) :: adjoint_array(0:)
${ti}$ :: itemp
integer(int_index) :: lo, hi
${t3}$ :: temp
lo = 0
hi = size( array, kind=int_index ) - 1
do while( lo < hi )
temp = array(lo)
array(lo) = array(hi)
array(hi) = temp
itemp = adjoint_array(lo)
adjoint_array(lo) = adjoint_array(hi)
adjoint_array(hi) = itemp
lo = lo + 1
hi = hi - 1
end do
end subroutine reverse_segment
end subroutine ${name1}$_${namei}$_sort_adjoint
#:endblock
#:endfor
#:endfor
end submodule stdlib_sorting_sort_adjoint
fortran-lang-stdlib-0ede301/src/sorting/stdlib_sorting_radix_sort.f90 0000664 0001750 0001750 00000042624 15135654166 026256 0 ustar alastair alastair submodule(stdlib_sorting) stdlib_sorting_radix_sort
implicit none
integer, parameter :: radix_bits = 8
integer, parameter :: radix_mask = 255
integer(kind=int16), parameter :: radix_bits_i16 = 8_int16
integer(kind=int16), parameter :: radix_mask_i16 = 255_int16
integer(kind=int32), parameter :: radix_bits_i32 = 8_int32
integer(kind=int32), parameter :: radix_mask_i32 = 255_int32
integer(kind=int64), parameter :: radix_bits_i64 = 8_int64
integer(kind=int64), parameter :: radix_mask_i64 = 255_int64
contains
! For int8, radix sort becomes counting sort, so buffer is not needed
pure subroutine radix_sort_u8_helper(N, arr)
integer(kind=int_index), intent(in) :: N
integer(kind=int8), dimension(N), intent(inout) :: arr
integer(kind=int_index) :: i
integer :: bin_idx
integer(kind=int_index), dimension(-128:127) :: counts
counts(:) = 0
do i = 1, N
bin_idx = arr(i)
counts(bin_idx) = counts(bin_idx) + 1
end do
i = 1
do bin_idx = -128, 127
do while (counts(bin_idx) > 0)
arr(i) = int(bin_idx, kind=int8)
i = i + 1
counts(bin_idx) = counts(bin_idx) - 1
end do
end do
end subroutine
pure subroutine radix_sort_u16_helper(N, arr, buf)
integer(kind=int_index), intent(in) :: N
integer(kind=int16), dimension(N), intent(inout) :: arr
integer(kind=int16), dimension(N), intent(inout) :: buf
integer(kind=int_index) :: i
integer :: b, b0, b1
integer(kind=int_index), dimension(0:radix_mask) :: c0, c1
c0(:) = 0
c1(:) = 0
do i = 1, N
b0 = iand(arr(i), radix_mask_i16)
b1 = ishft(arr(i), -radix_bits_i16)
c0(b0) = c0(b0) + 1
c1(b1) = c1(b1) + 1
end do
do b = 1, radix_mask
c0(b) = c0(b) + c0(b - 1)
c1(b) = c1(b) + c1(b - 1)
end do
do i = N, 1, -1
b0 = iand(arr(i), radix_mask_i16)
buf(c0(b0)) = arr(i)
c0(b0) = c0(b0) - 1
end do
do i = N, 1, -1
b1 = ishft(buf(i), -radix_bits_i16)
arr(c1(b1)) = buf(i)
c1(b1) = c1(b1) - 1
end do
end subroutine
pure subroutine radix_sort_u32_helper(N, arr, buf)
integer(kind=int_index), intent(in) :: N
integer(kind=int32), dimension(N), intent(inout) :: arr
integer(kind=int32), dimension(N), intent(inout) :: buf
integer(kind=int_index) :: i
integer :: b, b0, b1, b2, b3
integer(kind=int_index), dimension(0:radix_mask) :: c0, c1, c2, c3
c0(:) = 0
c1(:) = 0
c2(:) = 0
c3(:) = 0
do i = 1, N
b0 = iand(arr(i), radix_mask_i32)
b1 = iand(ishft(arr(i), -radix_bits_i32), radix_mask_i32)
b2 = iand(ishft(arr(i), -2*radix_bits_i32), radix_mask_i32)
b3 = ishft(arr(i), -3*radix_bits_i32)
c0(b0) = c0(b0) + 1
c1(b1) = c1(b1) + 1
c2(b2) = c2(b2) + 1
c3(b3) = c3(b3) + 1
end do
do b = 1, radix_mask
c0(b) = c0(b) + c0(b - 1)
c1(b) = c1(b) + c1(b - 1)
c2(b) = c2(b) + c2(b - 1)
c3(b) = c3(b) + c3(b - 1)
end do
do i = N, 1, -1
b0 = iand(arr(i), radix_mask_i32)
buf(c0(b0)) = arr(i)
c0(b0) = c0(b0) - 1
end do
do i = N, 1, -1
b1 = iand(ishft(buf(i), -radix_bits_i32), radix_mask_i32)
arr(c1(b1)) = buf(i)
c1(b1) = c1(b1) - 1
end do
do i = N, 1, -1
b2 = iand(ishft(arr(i), -2*radix_bits_i32), radix_mask_i32)
buf(c2(b2)) = arr(i)
c2(b2) = c2(b2) - 1
end do
do i = N, 1, -1
b3 = ishft(buf(i), -3*radix_bits_i32)
arr(c3(b3)) = buf(i)
c3(b3) = c3(b3) - 1
end do
end subroutine radix_sort_u32_helper
pure subroutine radix_sort_u64_helper(N, arr, buffer)
integer(kind=int_index), intent(in) :: N
integer(kind=int64), dimension(N), intent(inout) :: arr
integer(kind=int64), dimension(N), intent(inout) :: buffer
integer(kind=int_index) :: i
integer(kind=int64) :: b, b0, b1, b2, b3, b4, b5, b6, b7
integer(kind=int_index), dimension(0:radix_mask) :: c0, c1, c2, c3, c4, c5, c6, c7
c0(:) = 0
c1(:) = 0
c2(:) = 0
c3(:) = 0
c4(:) = 0
c5(:) = 0
c6(:) = 0
c7(:) = 0
do i = 1, N
b0 = iand(arr(i), radix_mask_i64)
b1 = iand(ishft(arr(i), -radix_bits_i64), radix_mask_i64)
b2 = iand(ishft(arr(i), -2*radix_bits_i64), radix_mask_i64)
b3 = iand(ishft(arr(i), -3*radix_bits_i64), radix_mask_i64)
b4 = iand(ishft(arr(i), -4*radix_bits_i64), radix_mask_i64)
b5 = iand(ishft(arr(i), -5*radix_bits_i64), radix_mask_i64)
b6 = iand(ishft(arr(i), -6*radix_bits_i64), radix_mask_i64)
b7 = ishft(arr(i), -7*radix_bits_i64)
c0(b0) = c0(b0) + 1
c1(b1) = c1(b1) + 1
c2(b2) = c2(b2) + 1
c3(b3) = c3(b3) + 1
c4(b4) = c4(b4) + 1
c5(b5) = c5(b5) + 1
c6(b6) = c6(b6) + 1
c7(b7) = c7(b7) + 1
end do
do b = 1, radix_mask
c0(b) = c0(b) + c0(b - 1)
c1(b) = c1(b) + c1(b - 1)
c2(b) = c2(b) + c2(b - 1)
c3(b) = c3(b) + c3(b - 1)
c4(b) = c4(b) + c4(b - 1)
c5(b) = c5(b) + c5(b - 1)
c6(b) = c6(b) + c6(b - 1)
c7(b) = c7(b) + c7(b - 1)
end do
do i = N, 1, -1
b0 = iand(arr(i), radix_mask_i64)
buffer(c0(b0)) = arr(i)
c0(b0) = c0(b0) - 1
end do
do i = N, 1, -1
b1 = iand(ishft(buffer(i), -radix_bits_i64), radix_mask_i64)
arr(c1(b1)) = buffer(i)
c1(b1) = c1(b1) - 1
end do
do i = N, 1, -1
b2 = iand(ishft(arr(i), -2*radix_bits_i64), radix_mask_i64)
buffer(c2(b2)) = arr(i)
c2(b2) = c2(b2) - 1
end do
do i = N, 1, -1
b3 = iand(ishft(buffer(i), -3*radix_bits_i64), radix_mask_i64)
arr(c3(b3)) = buffer(i)
c3(b3) = c3(b3) - 1
end do
do i = N, 1, -1
b4 = iand(ishft(arr(i), -4*radix_bits_i64), radix_mask_i64)
buffer(c4(b4)) = arr(i)
c4(b4) = c4(b4) - 1
end do
do i = N, 1, -1
b5 = iand(ishft(buffer(i), -5*radix_bits_i64), radix_mask_i64)
arr(c5(b5)) = buffer(i)
c5(b5) = c5(b5) - 1
end do
do i = N, 1, -1
b6 = iand(ishft(arr(i), -6*radix_bits_i64), radix_mask_i64)
buffer(c6(b6)) = arr(i)
c6(b6) = c6(b6) - 1
end do
do i = N, 1, -1
b7 = ishft(buffer(i), -7*radix_bits_i64)
arr(c7(b7)) = buffer(i)
c7(b7) = c7(b7) - 1
end do
end subroutine radix_sort_u64_helper
pure module subroutine int8_radix_sort(array, reverse)
integer(kind=int8), dimension(:), intent(inout) :: array
logical, intent(in), optional :: reverse
integer(kind=int8) :: item
integer(kind=int_index) :: i, N
N = size(array, kind=int_index)
call radix_sort_u8_helper(N, array)
if (optval(reverse, .false.)) then
do i = 1, N/2
item = array(i)
array(i) = array(N - i + 1)
array(N - i + 1) = item
end do
end if
end subroutine int8_radix_sort
pure module subroutine int16_radix_sort(array, work, reverse)
integer(kind=int16), dimension(:), intent(inout) :: array
integer(kind=int16), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
integer(kind=int_index) :: i, N, start, middle, end
integer(kind=int16), dimension(:), pointer :: buffer
integer(kind=int16) :: item
logical :: use_internal_buffer
N = size(array, kind=int_index)
if (present(work)) then
if (size(work, kind=int_index) < N) then
error stop "int16_radix_sort: work array is too small."
end if
use_internal_buffer = .false.
buffer => work
else
use_internal_buffer = .true.
allocate (buffer(N))
end if
call radix_sort_u16_helper(N, array, buffer)
! After calling `radix_sort_u_helper. The array is sorted as unsigned integers.
! In the view of signed array, the negative numbers are sorted but in the tail of the array.
! Use binary search to find the boundary, and move them to correct position.
if (array(1) >= 0 .and. array(N) < 0) then
start = 1
end = N
middle = (1 + N)/2
do while (.true.)
if (array(middle) >= 0) then
start = middle + 1
else
end = middle
end if
middle = (start + end)/2
if (start == end) exit
end do
buffer(1:(N - middle + 1)) = array(middle:N)
buffer(N - middle + 2:N) = array(1:middle - 1)
array(:) = buffer(:)
end if
if (optval(reverse, .false.)) then
do i = 1, N/2
item = array(i)
array(i) = array(N - i + 1)
array(N - i + 1) = item
end do
end if
if (use_internal_buffer) then
deallocate (buffer)
end if
end subroutine int16_radix_sort
pure module subroutine int32_radix_sort(array, work, reverse)
integer(kind=int32), dimension(:), intent(inout) :: array
integer(kind=int32), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
integer(kind=int_index) :: i, N, start, middle, end
integer(kind=int32), dimension(:), pointer :: buffer
integer(kind=int32) :: item
logical :: use_internal_buffer
N = size(array, kind=int_index)
if (present(work)) then
if (size(work, kind=int_index) < N) then
error stop "int32_radix_sort: work array is too small."
end if
use_internal_buffer = .false.
buffer => work
else
use_internal_buffer = .true.
allocate (buffer(N))
end if
call radix_sort_u32_helper(N, array, buffer)
if (array(1) >= 0 .and. array(N) < 0) then
start = 1
end = N
middle = (1 + N)/2
do while (.true.)
if (array(middle) >= 0) then
start = middle + 1
else
end = middle
end if
middle = (start + end)/2
if (start == end) exit
end do
buffer(1:(N - middle + 1)) = array(middle:N)
buffer(N - middle + 2:N) = array(1:middle - 1)
array(:) = buffer(:)
end if
if (optval(reverse, .false.)) then
do i = 1, N/2
item = array(i)
array(i) = array(N - i + 1)
array(N - i + 1) = item
end do
end if
if (use_internal_buffer) then
deallocate (buffer)
end if
end subroutine int32_radix_sort
module subroutine sp_radix_sort(array, work, reverse)
use iso_c_binding
real(kind=sp), dimension(:), intent(inout), target :: array
real(kind=sp), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
integer(kind=int_index) :: i, N, pos, rev_pos
integer(kind=int32), dimension(:), pointer :: arri32
integer(kind=int32), dimension(:), pointer :: buffer
real(kind=sp) :: item
logical :: use_internal_buffer
N = size(array, kind=int_index)
if (present(work)) then
if (size(work, kind=int_index) < N) then
error stop "sp_radix_sort: work array is too small."
end if
use_internal_buffer = .false.
call c_f_pointer(c_loc(work), buffer, [N])
else
use_internal_buffer = .true.
allocate (buffer(N))
end if
call c_f_pointer(c_loc(array), arri32, [N])
call radix_sort_u32_helper(N, arri32, buffer)
! After calling `radix_sort_u_helper. The array is sorted as unsigned integers.
! The positive real number is sorted, guaranteed by IEEE-754 standard.
! But the negative real number is sorted in a reversed order, and also in the tail of array.
! Remark that -0.0 is the minimum nagative integer, so using radix sort, -0.0 is naturally lesser than 0.0.
! In IEEE-754 standard, the bit representation of `Inf` is greater than all positive real numbers,
! and the `-Inf` is lesser than all negative real numbers. So the order of `Inf, -Inf` is ok.
! The bit representation of `NaN` may be positive or negative integers in different machine,
! thus if the array contains `NaN`, the result is undefined.
if (arri32(1) >= 0 .and. arri32(N) < 0) then
pos = 1
rev_pos = N
do while (arri32(rev_pos) < 0)
buffer(pos) = arri32(rev_pos)
pos = pos + 1
rev_pos = rev_pos - 1
end do
buffer(pos:N) = arri32(1:rev_pos)
arri32(:) = buffer(:)
end if
if (optval(reverse, .false.)) then
do i = 1, N/2
item = array(i)
array(i) = array(N - i + 1)
array(N - i + 1) = item
end do
end if
if (use_internal_buffer) then
deallocate (buffer)
end if
end subroutine sp_radix_sort
pure module subroutine int64_radix_sort(array, work, reverse)
integer(kind=int64), dimension(:), intent(inout) :: array
integer(kind=int64), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
integer(kind=int_index) :: i, N, start, middle, end
integer(kind=int64), dimension(:), pointer :: buffer
integer(kind=int64) :: item
logical :: use_internal_buffer
N = size(array, kind=int_index)
if (present(work)) then
if (size(work, kind=int_index) < N) then
error stop "int64_radix_sort: work array is too small."
end if
use_internal_buffer = .false.
buffer => work
else
use_internal_buffer = .true.
allocate (buffer(N))
end if
call radix_sort_u64_helper(N, array, buffer)
if (array(1) >= 0 .and. array(N) < 0) then
start = 1
end = N
middle = (1 + N)/2
do while (.true.)
if (array(middle) >= 0) then
start = middle + 1
else
end = middle
end if
middle = (start + end)/2
if (start == end) exit
end do
buffer(1:(N - middle + 1)) = array(middle:N)
buffer(N - middle + 2:N) = array(1:middle - 1)
array(:) = buffer(:)
end if
if (optval(reverse, .false.)) then
do i = 1, N/2
item = array(i)
array(i) = array(N - i + 1)
array(N - i + 1) = item
end do
end if
if (use_internal_buffer) then
deallocate (buffer)
end if
end subroutine int64_radix_sort
module subroutine dp_radix_sort(array, work, reverse)
use iso_c_binding
real(kind=dp), dimension(:), intent(inout), target :: array
real(kind=dp), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
integer(kind=int_index) :: i, N, pos, rev_pos
integer(kind=int64), dimension(:), pointer :: arri64
integer(kind=int64), dimension(:), pointer :: buffer
real(kind=dp) :: item
logical :: use_internal_buffer
N = size(array, kind=int_index)
if (present(work)) then
if (size(work, kind=int_index) < N) then
error stop "sp_radix_sort: work array is too small."
end if
use_internal_buffer = .false.
call c_f_pointer(c_loc(work), buffer, [N])
else
use_internal_buffer = .true.
allocate (buffer(N))
end if
call c_f_pointer(c_loc(array), arri64, [N])
call radix_sort_u64_helper(N, arri64, buffer)
if (arri64(1) >= 0 .and. arri64(N) < 0) then
pos = 1
rev_pos = N
do while (arri64(rev_pos) < 0)
buffer(pos) = arri64(rev_pos)
pos = pos + 1
rev_pos = rev_pos - 1
end do
buffer(pos:N) = arri64(1:rev_pos)
arri64(:) = buffer(:)
end if
if (optval(reverse, .false.)) then
do i = 1, N/2
item = array(i)
array(i) = array(N - i + 1)
array(N - i + 1) = item
end do
end if
if (use_internal_buffer) then
deallocate (buffer)
end if
end subroutine dp_radix_sort
end submodule stdlib_sorting_radix_sort
fortran-lang-stdlib-0ede301/src/sorting/stdlib_sorting_ord_sort.fypp 0000664 0001750 0001750 00000043246 15135654166 026314 0 ustar alastair alastair #include "macros.inc"
#:include "common.fypp"
#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_TYPES, INT_KINDS, INT_CPPS))
#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_TYPES, REAL_KINDS, REAL_CPPS))
#:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_TYPES, STRING_KINDS, STRING_CPPS))
#:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=:)"], ["character(len=len(array))"], ["char"], [""]))
#:set BITSETS_TYPES_ALT_NAME = list(zip(BITSETS_TYPES, BITSETS_TYPES, BITSETS_TYPES, BITSETS_KINDS, BITSETS_CPPS))
#! For better code reuse in fypp, make lists that contain the input types,
#! with each having output types and a separate name prefix for subroutines
#! This approach allows us to have the same code for all input types.
#:set IRSCB_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME &
& + BITSETS_TYPES_ALT_NAME
#:set SIGN_NAME = ["increase", "decrease"]
#:set SIGN_TYPE = [">", "<"]
#:set SIGN_OPP_TYPE = ["<", ">"]
#:set SIGN_NAME_TYPE = list(zip(SIGN_NAME, SIGN_TYPE, SIGN_OPP_TYPE))
!! Licensing:
!!
!! This file is subjec† both to the Fortran Standard Library license, and
!! to additional licensing requirements as it contains translations of
!! other software.
!!
!! The Fortran Standard Library, including this file, is distributed under
!! the MIT license that should be included with the library's distribution.
!!
!! Copyright (c) 2021 Fortran stdlib developers
!!
!! 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 sellcopies 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.
!!
!! 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.
!!
!! The generic subroutine, `ORD_SORT`, is substantially a translation to
!! Fortran 2008 of the `"Rust" sort` sorting routines in
!! [`slice.rs`](https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs)
!! The `rust sort` implementation is distributed with the header:
!!
!! Copyright 2012-2015 The Rust Project Developers. See the COPYRIGHT
!! file at the top-level directory of this distribution and at
!! http://rust-lang.org/COPYRIGHT.
!!
!! Licensed under the Apache License, Version 2.0 or the MIT license
!! , at your
!! option. This file may not be copied, modified, or distributed
!! except according to those terms.
!!
!! so the license for the original`slice.rs` code is compatible with the use
!! of modified versions of the code in the Fortran Standard Library under
!! the MIT license.
submodule(stdlib_sorting) stdlib_sorting_ord_sort
implicit none
contains
#:for t1, t2, t3, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
module subroutine ${name1}$_ord_sort( array, work, reverse )
${t1}$, intent(inout) :: array(0:)
${t3}$, intent(out), optional :: work(0:)
logical, intent(in), optional :: reverse
if (optval(reverse, .false.)) then
call ${name1}$_decrease_ord_sort(array, work)
else
call ${name1}$_increase_ord_sort(array, work)
endif
end subroutine ${name1}$_ord_sort
#:endblock
#:endfor
#:for sname, signt, signoppt in SIGN_NAME_TYPE
#:for t1, t2, t3, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
subroutine ${name1}$_${sname}$_ord_sort( array, work )
! A translation to Fortran 2008, of the `"Rust" sort` algorithm found in
! `slice.rs`
! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159
! The Rust version in turn is a simplification of the Timsort algorithm
! described in
! https://svn.python.org/projects/python/trunk/Objects/listsort.txt, as
! it drops both the use of 'galloping' to identify bounds of regions to be
! sorted and the estimation of the optimal `run size`. However it remains
! a hybrid sorting algorithm combining an iterative Merge sort controlled
! by a stack of `RUNS` identified by regions of uniformly decreasing or
! non-decreasing sequences that may be expanded to a minimum run size and
! initially processed by an insertion sort.
!
! Note the Fortran implementation simplifies the logic as it only has to
! deal with Fortran arrays of intrinsic types and not the full generality
! of Rust's arrays and lists for arbitrary types. It also adds the
! estimation of the optimal `run size` as suggested in Tim Peters'
! original `listsort.txt`, and an optional `work` array to be used as
! scratch memory.
${t1}$, intent(inout) :: array(0:)
${t3}$, intent(out), optional :: work(0:)
${t2}$, allocatable :: buf(:)
integer(int_index) :: array_size
integer :: stat
array_size = size( array, kind=int_index )
! If necessary allocate buffers to serve as scratch memory.
if ( present(work) ) then
if ( size(work, kind=int_index) < array_size/2 ) then
error stop "${name1}$_${sname}$_ord_sort: work array is too small."
end if
! Use the work array as scratch memory
call merge_sort( array, work )
else
! Allocate a buffer to use as scratch memory.
#:if t1[0:4] == "char"
allocate( ${t3}$ :: buf(0:array_size/2-1), &
stat=stat )
#:else
allocate( buf(0:array_size/2-1), stat=stat )
#:endif
if ( stat /= 0 ) error stop "${name1}$_${sname}$_ord_sort: Allocation of buffer failed."
call merge_sort( array, buf )
end if
contains
pure function calc_min_run( n ) result(min_run)
!! Returns the minimum length of a run from 32-63 so that N/MIN_RUN is
!! less than or equal to a power of two. See
!! https://svn.python.org/projects/python/trunk/Objects/listsort.txt
integer(int_index) :: min_run
integer(int_index), intent(in) :: n
integer(int_index) :: num, r
num = n
r = 0_int_index
do while( num >= 64 )
r = ior( r, iand(num, 1_int_index) )
num = ishft(num, -1_int_index)
end do
min_run = num + r
end function calc_min_run
pure subroutine insertion_sort( array )
! Sorts `ARRAY` using an insertion sort.
${t1}$, intent(inout) :: array(0:)
integer(int_index) :: i, j
${t3}$ :: key
do j=1, size(array, kind=int_index)-1
key = array(j)
i = j - 1
do while( i >= 0 )
if ( array(i) ${signoppt}$= key ) exit
array(i+1) = array(i)
i = i - 1
end do
array(i+1) = key
end do
end subroutine insertion_sort
pure function collapse( runs ) result ( r )
! Examine the stack of runs waiting to be merged, identifying adjacent runs
! to be merged until the stack invariants are restablished:
!
! 1. len(-3) > len(-2) + len(-1)
! 2. len(-2) > len(-1)
integer(int_index) :: r
type(run_type), intent(in), target :: runs(0:)
integer(int_index) :: n
logical :: test
n = size(runs, kind=int_index)
test = .false.
if (n >= 2) then
if ( runs( n-1 ) % base == 0 .or. &
runs( n-2 ) % len <= runs(n-1) % len ) then
test = .true.
else if ( n >= 3 ) then ! X exists
if ( runs(n-3) % len <= &
runs(n-2) % len + runs(n-1) % len ) then
test = .true.
! |X| <= |Y| + |Z| => will need to merge due to rho1 or rho2
else if( n >= 4 ) then
if ( runs(n-4) % len <= &
runs(n-3) % len + runs(n-2) % len ) then
test = .true.
! |W| <= |X| + |Y| => will need to merge due to rho1 or rho3
end if
end if
end if
end if
if ( test ) then
! By default merge Y & Z, rho2 or rho3
if ( n >= 3 ) then
if ( runs(n-3) % len < runs(n-1) % len ) then
r = n - 3
! |X| < |Z| => merge X & Y, rho1
return
end if
end if
r = n - 2
! |Y| <= |Z| => merge Y & Z, rho4
return
else
r = -1
end if
end function collapse
pure subroutine insert_head( array )
! Inserts `array(0)` into the pre-sorted sequence `array(1:)` so that the
! whole `array(0:)` becomes sorted, copying the first element into
! a temporary variable, iterating until the right place for it is found.
! copying every traversed element into the slot preceding it, and finally,
! copying data from the temporary variable into the resulting hole.
${t1}$, intent(inout) :: array(0:)
${t3}$ :: tmp
integer(int_index) :: i
tmp = array(0)
find_hole: do i=1, size(array, kind=int_index)-1
if ( array(i) ${signt}$= tmp ) exit find_hole
array(i-1) = array(i)
end do find_hole
array(i-1) = tmp
end subroutine insert_head
subroutine merge_sort( array, buf )
! The Rust merge sort borrows some (but not all) of the ideas from TimSort,
! which is described in detail at
! (http://svn.python.org/projects/python/trunk/Objects/listsort.txt).
!
! The algorithm identifies strictly descending and non-descending
! subsequences, which are called natural runs. Where these runs are less
! than a minimum run size they are padded by adding additional samples
! using an insertion sort. The merge process is driven by a stack of
! pending unmerged runs. Each newly found run is pushed onto the stack,
! and then pairs of adjacentd runs are merged until these two invariants
! are satisfied:
!
! 1. for every `i` in `1..size(runs)-1`: `runs(i - 1)%len > runs(i)%len`
! 2. for every `i` in `2..size(runs)-1`: `runs(i - 2)%len >
! runs(i - 1)%len + runs(i)%len`
!
! The invariants ensure that the total running time is `O(n log n)`
! worst-case.
${t1}$, intent(inout) :: array(0:)
${t3}$, intent(inout) :: buf(0:)
integer(int_index) :: array_size, finish, min_run, r, r_count, &
start
type(run_type) :: runs(0:max_merge_stack-1), left, right
array_size = size(array, kind=int_index)
! Very short runs are extended using insertion sort to span at least
! min_run elements. Slices of up to this length are sorted using insertion
! sort.
min_run = calc_min_run( array_size )
if ( array_size <= min_run ) then
if ( array_size >= 2 ) call insertion_sort( array )
return
end if
! Following Rust sort, natural runs in `array` are identified by traversing
! it backwards. By traversing it backward, merges more often go in the
! opposite direction (forwards). According to developers of Rust sort,
! merging forwards is slightly faster than merging backwards. Therefore
! identifying runs by traversing backwards should improve performance.
r_count = 0
finish = array_size - 1
do while ( finish >= 0 )
! Find the next natural run, and reverse it if it's strictly descending.
start = finish
if ( start > 0 ) then
start = start - 1
if ( array(start+1) ${signoppt}$ array(start) ) then
Descending: do while ( start > 0 )
if ( array(start) ${signt}$= array(start-1) ) &
exit Descending
start = start - 1
end do Descending
call reverse_segment( array(start:finish) )
else
Ascending: do while( start > 0 )
if ( array(start) ${signoppt}$ array(start-1) ) exit Ascending
start = start - 1
end do Ascending
end if
end if
! If the run is too short insert some more elements using an insertion sort.
Insert: do while ( start > 0 )
if ( finish - start >= min_run - 1 ) exit Insert
start = start - 1
call insert_head( array(start:finish) )
end do Insert
if ( start == 0 .and. finish == array_size - 1 ) return
runs(r_count) = run_type( base = start, &
len = finish - start + 1 )
finish = start-1
r_count = r_count + 1
! Determine whether pairs of adjacent runs need to be merged to satisfy
! the invariants, and, if so, merge them.
Merge_loop: do
r = collapse( runs(0:r_count - 1) )
if ( r < 0 .or. r_count <= 1 ) exit Merge_loop
left = runs( r + 1 )
right = runs( r )
call merge( array( left % base: &
right % base + right % len - 1 ), &
left % len, buf )
runs(r) = run_type( base = left % base, &
len = left % len + right % len )
if ( r == r_count - 3 ) runs(r+1) = runs(r+2)
r_count = r_count - 1
end do Merge_loop
end do
if ( r_count /= 1 ) &
error stop "MERGE_SORT completed without RUN COUNT == 1."
end subroutine merge_sort
pure subroutine merge( array, mid, buf )
! Merges the two non-decreasing runs `ARRAY(0:MID-1)` and `ARRAY(MID:)`
! using `BUF` as temporary storage, and stores the merged runs into
! `ARRAY(0:)`. `MID` must be > 0, and < `SIZE(ARRAY)-1`. Buffer `BUF`
! must be long enough to hold the shorter of the two runs.
${t1}$, intent(inout) :: array(0:)
integer(int_index), intent(in) :: mid
${t3}$, intent(inout) :: buf(0:)
integer(int_index) :: array_len, i, j, k
array_len = size(array, kind=int_index)
! Merge first copies the shorter run into `buf`. Then, depending on which
! run was shorter, it traces the copied run and the longer run forwards
! (or backwards), comparing their next unprocessed elements and then
! copying the lesser (or greater) one into `array`.
if ( mid <= array_len - mid ) then ! The left run is shorter.
buf(0:mid-1) = array(0:mid-1)
i = 0
j = mid
merge_lower: do k = 0, array_len-1
if ( buf(i) ${signoppt}$= array(j) ) then
array(k) = buf(i)
i = i + 1
if ( i >= mid ) exit merge_lower
else
array(k) = array(j)
j = j + 1
if ( j >= array_len ) then
array(k+1:) = buf(i:mid-1)
exit merge_lower
end if
end if
end do merge_lower
else ! The right run is shorter ! check that it is stable
buf(0:array_len-mid-1) = array(mid:array_len-1)
i = mid - 1
j = array_len - mid -1
merge_upper: do k = array_len-1, 0, -1
if ( buf(j) ${signt}$= array(i) ) then
array(k) = buf(j)
j = j - 1
if ( j < 0 ) exit merge_upper
else
array(k) = array(i)
i = i - 1
if ( i < 0 ) then
array(0:k-1) = buf(0:j)
exit merge_upper
end if
end if
end do merge_upper
end if
end subroutine merge
pure subroutine reverse_segment( array )
! Reverse a segment of an array in place
${t1}$, intent(inout) :: array(0:)
integer(int_index) :: lo, hi
${t3}$ :: temp
lo = 0
hi = size( array, kind=int_index ) - 1
do while( lo < hi )
temp = array(lo)
array(lo) = array(hi)
array(hi) = temp
lo = lo + 1
hi = hi - 1
end do
end subroutine reverse_segment
end subroutine ${name1}$_${sname}$_ord_sort
#:endblock
#:endfor
#:endfor
end submodule stdlib_sorting_ord_sort
fortran-lang-stdlib-0ede301/src/sorting/stdlib_sorting.fypp 0000664 0001750 0001750 00000074164 15135654166 024404 0 ustar alastair alastair #include "macros.inc"
#:include "common.fypp"
#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_KINDS, INT_CPPS))
#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_KINDS, REAL_CPPS))
#:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_KINDS, STRING_CPPS))
#:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=len(array))"], ["char"], [""]))
#:set BITSETS_TYPES_ALT_NAME = list(zip(BITSETS_TYPES, BITSETS_TYPES, BITSETS_KINDS, BITSETS_CPPS))
#:set INT_INDEX_TYPES_ALT_NAME = list(zip(["int_index", "int_index_low"], ["integer(int_index)", "integer(int_index_low)"], ["default", "low"]))
#! For better code reuse in fypp, make lists that contain the input types,
#! with each having output types and a separate name prefix for subroutines
#! This approach allows us to have the same code for all input types.
#:set IRSCB_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME &
& + BITSETS_TYPES_ALT_NAME
#:set IR_INDEX_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME
!! Licensing:
!!
!! This file is subject both to the Fortran Standard Library license, and
!! to additional licensing requirements as it contains translations of
!! other software.
!!
!! The Fortran Standard Library, including this file, is distributed under
!! the MIT license that should be included with the library's distribution.
!!
!! Copyright (c) 2021 Fortran stdlib developers
!!
!! 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 sellcopies 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.
!!
!! 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.
!!
!! Two of the generic subroutines, `ORD_SORT` and `SORT_INDEX`, are
!! substantially translations to Fortran 2008 of the `"Rust" sort` sorting
!! routines in
!! [`slice.rs`](https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs)
!! The `rust sort` implementation is distributed with the header:
!!
!! Copyright 2012-2015 The Rust Project Developers. See the COPYRIGHT
!! file at the top-level directory of this distribution and at
!! http://rust-lang.org/COPYRIGHT.
!!
!! Licensed under the Apache License, Version 2.0 or the MIT license
!! , at your
!! option. This file may not be copied, modified, or distributed
!! except according to those terms.
!!
!! so the license for the original`slice.rs` code is compatible with the use
!! of modified versions of the code in the Fortran Standard Library under
!! the MIT license.
!!
!! One of the generic subroutines, `SORT`, is substantially a
!! translation to Fortran 2008, of the `introsort` of David Musser.
!! David Musser has given permission to include a variant of `introsort`
!! in the Fortran Standard Library under the MIT license provided
!! we cite:
!!
!! Musser, D.R., “Introspective Sorting and Selection Algorithms,”
!! Software—Practice and Experience, Vol. 27(8), 983–993 (August 1997).
!!
!! as the official source of the algorithm.
module stdlib_sorting
!! This module implements overloaded sorting subroutines named `ORD_SORT`,
!! `SORT_INDEX`, and `SORT`, that each can be used to sort four kinds
!! of `INTEGER` arrays, three kinds of `REAL` arrays, `character(len=*)` arrays,
!! and arrays of `type(string_type)`.
!! ([Specification](../page/specs/stdlib_sorting.html))
!!
!! By default sorting is in order of
!! increasing value, but there is an option to sort in decreasing order.
!! All the subroutines have worst case run time performance of `O(N Ln(N))`,
!! but on largely sorted data `ORD_SORT` and `SORT_INDEX` can have a run time
!! performance of `O(N)`.
!!
!! `ORD_SORT` is a translation of the `"Rust" sort` sorting algorithm in
!! `slice.rs`:
!! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs
!! which in turn is inspired by the `timsort` algorithm of Tim Peters,
!! http://svn.python.org/projects/python/trunk/Objects/listsort.txt.
!! `ORD_SORT` is a hybrid stable comparison algorithm combining `merge sort`,
!! and `insertion sort`. It is always at worst O(N Ln(N)) in sorting random
!! data, having a performance about 25% slower than `SORT` on such
!! data, but has much better performance than `SORT` on partially
!! sorted data, having O(N) performance on uniformly non-increasing or
!! non-decreasing data.
!!
!! `SORT_INDEX` is a modification of `ORD_SORT` so that in addition to
!! sorting the input array, it returns the indices that map to a
!! stable sort of the original array. These indices are
!! intended to be used to sort data that is correlated with the input
!! array, e.g., different arrays in a database, different columns of a
!! rank 2 array, different elements of a derived type. It is less
!! efficient than `ORD_SORT` at sorting a simple array.
!!
!! `SORT` uses the `INTROSORT` sorting algorithm of David Musser,
!! http://www.cs.rpi.edu/~musser/gp/introsort.ps. `introsort` is a hybrid
!! unstable comparison algorithm combining `quicksort`, `insertion sort`, and
!! `heap sort`. While this algorithm is always O(N Ln(N)) it is relatively
!! fast on randomly ordered data, but inconsistent in performance on partly
!! sorted data, sometimes having `merge sort` performance, sometimes having
!! better than `quicksort` performance. `UNORD_SOORT` is about 25%
!! more efficient than `ORD_SORT` at sorting purely random data, but af an
!! order of `Ln(N)` less efficient at sorting partially sorted data.
use stdlib_kinds, only: &
int8, &
int16, &
int32, &
int64, &
sp, &
dp, &
xdp, &
qp
use stdlib_optval, only: optval
use stdlib_string_type, only: string_type, assignment(=), operator(>), &
operator(>=), operator(<), operator(<=)
#if STDLIB_BITSETS
use stdlib_bitsets, only: bitset_64, bitset_large, &
assignment(=), operator(>), operator(>=), operator(<), operator(<=)
#endif
implicit none
private
integer, parameter, public :: int_index = int64 !! Integer kind for indexing
integer, parameter, public :: int_index_low = int32 !! Integer kind for indexing using less than `huge(1_int32)` values
! Constants for use by tim_sort
integer, parameter :: &
! The maximum number of entries in a run stack, good for an array of
! 2**64 elements see
! https://svn.python.org/projects/python/trunk/Objects/listsort.txt
max_merge_stack = int( ceiling( log( 2._dp**64 ) / &
log(1.6180339887_dp) ) )
type run_type
!! Version: experimental
!!
!! Used to pass state around in a stack among helper functions for the
!! `ORD_SORT` and `SORT_INDEX` algorithms
integer(int_index) :: base = 0
integer(int_index) :: len = 0
end type run_type
public ord_sort
!! Version: experimental
!!
!! The generic subroutine implementing the `ORD_SORT` algorithm to return
!! an input array with its elements sorted in order of (non-)decreasing
!! value. Its use has the syntax:
!!
!! call ord_sort( array[, work, reverse] )
!!
!! with the arguments:
!!
!! * array: the rank 1 array to be sorted. It is an `intent(inout)`
!! argument of any of the types `integer(int8)`, `integer(int16)`,
!! `integer(int32)`, `integer(int64)`, `real(real32)`, `real(real64)`,
!! `real(real128)`, `character(*)`, `type(string_type)`,
!! `type(bitset_64)`, `type(bitset_large)`. If both the
!! type of `array` is real and at least one of the elements is a
!! `NaN`, then the ordering of the result is undefined. Otherwise it
!! is defined to be the original elements in non-decreasing order.
!!
!! * work (optional): shall be a rank 1 array of the same type as
!! `array`, and shall have at least `size(array)/2` elements. It is an
!! `intent(out)` argument to be used as "scratch" memory
!! for internal record keeping. If associated with an array in static
!! storage, its use can significantly reduce the stack memory requirements
!! for the code. Its value on return is undefined.
!!
!! * `reverse` (optional): shall be a scalar of type default logical. It
!! is an `intent(in)` argument. If present with a value of `.true.` then
!! `array` will be sorted in order of non-increasing values in stable
!! order. Otherwise index will sort `array` in order of non-decreasing
!! values in stable order.
!!
!!#### Example
!!
!!```fortran
!! ...
!! ! Read arrays from sorted files
!! call read_sorted_file( 'dummy_file1', array1 )
!! call read_sorted_file( 'dummy_file2', array2 )
!! ! Concatenate the arrays
!! allocate( array( size(array1) + size(array2) ) )
!! array( 1:size(array1) ) = array1(:)
!! array( size(array1)+1:size(array1)+size(array2) ) = array2(:)
!! ! Sort the resulting array
!! call ord_sort( array, work )
!! ! Process the sorted array
!! call array_search( array, values )
!! ...
!!```
public sort
!! Version: experimental
!!
!! The generic subroutine implementing the `SORT` algorithm to return
!! an input array with its elements sorted in order of (non-)decreasing
!! value. Its use has the syntax:
!!
!! call sort( array[, reverse] )
!!
!! with the arguments:
!!
!! * array: the rank 1 array to be sorted. It is an `intent(inout)`
!! argument of any of the types `integer(int8)`, `integer(int16)`,
!! `integer(int32)`, `integer(int64)`, `real(real32)`, `real(real64)`,
!! `real(real128)`, `character(*)`, `type(string_type)`,
!! `type(bitset_64)`, `type(bitset_large)`. If both the type
!! of `array` is real and at least one of the elements is a `NaN`, then
!! the ordering of the result is undefined. Otherwise it is defined to be the
!! original elements in non-decreasing order.
!! * `reverse` (optional): shall be a scalar of type default logical. It
!! is an `intent(in)` argument. If present with a value of `.true.` then
!! `array` will be sorted in order of non-increasing values in unstable
!! order. Otherwise index will sort `array` in order of non-decreasing
!! values in unstable order.
!!
!!#### Example
!!
!!```fortran
!! ...
!! ! Read random data from a file
!! call read_file( 'dummy_file', array )
!! ! Sort the random data
!! call sort( array )
!! ! Process the sorted data
!! call array_search( array, values )
!! ...
!!```
public radix_sort
!! Version: experimental
!!
!! The generic subroutine implementing the LSD radix sort algorithm to return
!! an input array with its elements sorted in order of (non-)decreasing
!! value. Its use has the syntax:
!!
!! call radix_sort( array[, work, reverse] )
!!
!! with the arguments:
!!
!! * array: the rank 1 array to be sorted. It is an `intent(inout)`
!! argument of any of the types `integer(int8)`, `integer(int16)`,
!! `integer(int32)`, `integer(int64)`, `real(real32)`, `real(real64)`.
!! If both the type of `array` is real and at least one of the
!! elements is a `NaN`, then the ordering of the result is undefined.
!! Otherwise it is defined to be the original elements in
!! non-decreasing order. Especially, -0.0 is lesser than 0.0.
!!
!! * work (optional): shall be a rank 1 array of the same type as
!! `array`, and shall have at least `size(array)` elements. It is an
!! `intent(inout)` argument to be used as buffer. Its value on return is
!! undefined. If it is not present, `radix_sort` will allocate a
!! buffer for use, and deallocate it before return. If you do several
!! similar `radix_sort`s, reusing the `work` array is a good parctice.
!! This argument is not present for `int8_radix_sort` because it use
!! counting sort, so no buffer is needed.
!!
!! * `reverse` (optional): shall be a scalar of type default logical. It
!! is an `intent(in)` argument. If present with a value of `.true.` then
!! `array` will be sorted in order of non-increasing values in stable
!! order. Otherwise index will sort `array` in order of non-decreasing
!! values in stable order.
!!
!!#### Example
!!
!!```fortran
!! ...
!! ! Read random data from a file
!! call read_file( 'dummy_file', array )
!! ! Sort the random data
!! call radix_sort( array )
!! ...
!!```
public sort_adjoint
!! Version: experimental
!!
!! The generic subroutine implementing the `SORT_ADJ` algorithm to
!! return an adjoint array whose elements are sorted in the same order
!! as the input array in the
!! desired direction. It is primarily intended to be used to sort a
!! rank 1 `integer` or `real` array based on the values of a component of the array.
!! Its use has the syntax:
!!
!! call sort_adjoint( array, adjoint_array[, work, iwork, reverse ] )
!!
!! with the arguments:
!!
!! * array: the rank 1 array to be sorted. It is an `intent(inout)`
!! argument of any of the types `integer(int8)`, `integer(int16)`,
!! `integer(int32)`, `integer(int64)`, `real(real32)`, `real(real64)`,
!! `real(real128)`, `character(*)`, `type(string_type)`,
!! `type(bitset_64)`, `type(bitset_large)`. If both the
!! type of `array` is real and at least one of the elements is a `NaN`,
!! then the ordering of the `array` and `adjoint_array` results is undefined.
!! Otherwise it is defined to be as specified by reverse.
!!
!! * adjoint_array: a rank 1 `integer` or `real` array. It is an `intent(inout)`
!! argument. Its size shall be the
!! same as `array`. On return, its elements are sorted in the same order
!! as the input `array` in the direction specified by `reverse`.
!!
!! * work (optional): shall be a rank 1 array of the same type as
!! `array`, and shall have at least `size(array)/2` elements. It is an
!! `intent(out)` argument to be used as "scratch" memory
!! for internal record keeping. If associated with an array in static
!! storage, its use can significantly reduce the stack memory requirements
!! for the code. Its value on return is undefined.
!!
!! * iwork (optional): shall be a rank 1 integer array of the same type as `adjoint_array`,
!! and shall have at least `size(array)/2` elements. It is an
!! `intent(out)` argument to be used as "scratch" memory
!! for internal record keeping. If associated with an array in static
!! storage, its use can significantly reduce the stack memory requirements
!! for the code. Its value on return is undefined.
!!
!! * `reverse` (optional): shall be a scalar of type default logical. It
!! is an `intent(in)` argument. If present with a value of `.true.` then
!! `array` will be sorted in order of non-increasing values in stable
!! order. Otherwise `array` will be sorted in order of non-decreasing
!! values in stable order.
!!
!!#### Examples
!!
!! Sorting a related rank one array:
!!
!!```Fortran
!!program example_sort_adjoint
!! use stdlib_sorting, only: sort_adjoint
!! implicit none
!! integer, allocatable :: array(:)
!! real, allocatable :: adj(:)
!!
!! array = [5, 4, 3, 1, 10, 4, 9]
!! allocate(adj, source=real(array))
!!
!! call sort_adjoint(array, adj)
!!
!! print *, array !print [1, 3, 4, 4, 5, 9, 10]
!! print *, adj !print [1., 3., 4., 4., 5., 9., 10.]
!!
!!end program example_sort_adjoint
!!```
public sort_index
!! Version: experimental
!!
!! The generic subroutine implementing the `SORT_INDEX` algorithm to
!! return an index array whose elements would sort the input array in the
!! desired direction. It is primarily intended to be used to sort a
!! derived type array based on the values of a component of the array.
!! Its use has the syntax:
!!
!! call sort_index( array, index[, work, iwork, reverse ] )
!!
!! with the arguments:
!!
!! * array: the rank 1 array to be sorted. It is an `intent(inout)`
!! argument of any of the types `integer(int8)`, `integer(int16)`,
!! `integer(int32)`, `integer(int64)`, `real(real32)`, `real(real64)`,
!! `real(real128)`, `character(*)`, `type(string_type)`,
!! `type(bitset_64)`, `type(bitset_large)`. If both the
!! type of `array` is real and at least one of the elements is a `NaN`,
!! then the ordering of the `array` and `index` results is undefined.
!! Otherwise it is defined to be as specified by reverse.
!!
!! * index: a rank 1 array of sorting indices. It is an `intent(out)`
!! argument of the type `integer(int_index)`. Its size shall be the
!! same as `array`. On return, if defined, its elements would
!! sort the input `array` in the direction specified by `reverse`.
!!
!! * work (optional): shall be a rank 1 array of the same type as
!! `array`, and shall have at least `size(array)/2` elements. It is an
!! `intent(out)` argument to be used as "scratch" memory
!! for internal record keeping. If associated with an array in static
!! storage, its use can significantly reduce the stack memory requirements
!! for the code. Its value on return is undefined.
!!
!! * iwork (optional): shall be a rank 1 integer array of kind `int_index`,
!! and shall have at least `size(array)/2` elements. It is an
!! `intent(out)` argument to be used as "scratch" memory
!! for internal record keeping. If associated with an array in static
!! storage, its use can significantly reduce the stack memory requirements
!! for the code. Its value on return is undefined.
!!
!! * `reverse` (optional): shall be a scalar of type default logical. It
!! is an `intent(in)` argument. If present with a value of `.true.` then
!! `index` will sort `array` in order of non-increasing values in stable
!! order. Otherwise index will sort `array` in order of non-decreasing
!! values in stable order.
!!
!!#### Examples
!!
!! Sorting a related rank one array:
!!
!!```Fortran
!! subroutine sort_related_data( a, b, work, index, iwork )
!! ! Sort `b` in terms or its related array `a`
!! integer, intent(inout) :: a(:)
!! integer(int32), intent(inout) :: b(:) ! The same size as a
!! integer(int32), intent(out) :: work(:)
!! integer(int_index), intent(out) :: index(:)
!! integer(int_index), intent(out) :: iwork(:)
!! ! Find the indices to sort a
!! call sort_index(a, index(1:size(a)),&
!! work(1:size(a)/2), iwork(1:size(a)/2))
!! ! Sort b based on the sorting of a
!! b(:) = b( index(1:size(a)) )
!! end subroutine sort_related_data
!!```
!!
!! Sorting a rank 2 array based on the data in a column
!!
!!```Fortran
!! subroutine sort_related_data( array, column, work, index, iwork )
!! ! Sort `a_data` in terms or its component `a`
!! integer, intent(inout) :: a(:,:)
!! integer(int32), intent(in) :: column
!! integer(int32), intent(out) :: work(:)
!! integer(int_index), intent(out) :: index(:)
!! integer(int_index), intent(out) :: iwork(:)
!! integer, allocatable :: dummy(:)
!! integer :: i
!! allocate(dummy(size(a, dim=1)))
!! ! Extract a component of `a_data`
!! dummy(:) = a(:, column)
!! ! Find the indices to sort the column
!! call sort_index(dummy, index(1:size(dummy)),&
!! work(1:size(dummy)/2), iwork(1:size(dummy)/2))
!! ! Sort a based on the sorting of its column
!! do i=1, size(a, dim=2)
!! a(:, i) = a(index(1:size(a, dim=1)), i)
!! end do
!! end subroutine sort_related_data
!!```
!!
!! Sorting an array of a derived type based on the dsta in one component
!!```fortran
!! subroutine sort_a_data( a_data, a, work, index, iwork )
!! ! Sort `a_data` in terms or its component `a`
!! type(a_type), intent(inout) :: a_data(:)
!! integer(int32), intent(inout) :: a(:)
!! integer(int32), intent(out) :: work(:)
!! integer(int_index), intent(out) :: index(:)
!! integer(int_index), intent(out) :: iwork(:)
!! ! Extract a component of `a_data`
!! a(1:size(a_data)) = a_data(:) % a
!! ! Find the indices to sort the component
!! call sort_index(a(1:size(a_data)), index(1:size(a_data)),&
!! work(1:size(a_data)/2), iwork(1:size(a_data)/2))
!! ! Sort a_data based on the sorting of that component
!! a_data(:) = a_data( index(1:size(a_data)) )
!! end subroutine sort_a_data
!!```
interface ord_sort
!! Version: experimental
!!
!! The generic subroutine interface implementing the `ORD_SORT` algorithm,
!! a translation to Fortran 2008, of the `"Rust" sort` algorithm found in
!! `slice.rs`
!! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159
!! `ORD_SORT` is a hybrid stable comparison algorithm combining `merge sort`,
!! and `insertion sort`.
!! ([Specification](../page/specs/stdlib_sorting.html#ord_sort-sorts-an-input-array))
!!
!! It is always at worst O(N Ln(N)) in sorting random
!! data, having a performance about 25% slower than `SORT` on such
!! data, but has much better performance than `SORT` on partially
!! sorted data, having O(N) performance on uniformly non-increasing or
!! non-decreasing data.
#:for t1, t2, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
module subroutine ${name1}$_ord_sort( array, work, reverse )
!! Version: experimental
!!
!! `${name1}$_ord_sort( array )` sorts the input `ARRAY` of type `${t1}$`
!! using a hybrid sort based on the `"Rust" sort` algorithm found in `slice.rs`
${t1}$, intent(inout) :: array(0:)
${t2}$, intent(out), optional :: work(0:)
logical, intent(in), optional :: reverse
end subroutine ${name1}$_ord_sort
#:endblock
#:endfor
end interface ord_sort
interface radix_sort
!! Version: experimental
!!
!! The generic subroutine interface implementing the LSD radix sort algorithm,
!! see https://en.wikipedia.org/wiki/Radix_sort for more details.
!! It is always O(N) in sorting random data, but need a O(N) buffer.
!! ([Specification](../page/specs/stdlib_sorting.html#radix_sort-sorts-an-input-array))
!!
pure module subroutine int8_radix_sort(array, reverse)
integer(kind=int8), dimension(:), intent(inout) :: array
logical, intent(in), optional :: reverse
end subroutine int8_radix_sort
pure module subroutine int16_radix_sort(array, work, reverse)
integer(kind=int16), dimension(:), intent(inout) :: array
integer(kind=int16), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
end subroutine int16_radix_sort
pure module subroutine int32_radix_sort(array, work, reverse)
integer(kind=int32), dimension(:), intent(inout) :: array
integer(kind=int32), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
end subroutine int32_radix_sort
pure module subroutine int64_radix_sort(array, work, reverse)
integer(kind=int64), dimension(:), intent(inout) :: array
integer(kind=int64), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
end subroutine int64_radix_sort
module subroutine sp_radix_sort(array, work, reverse)
real(kind=sp), dimension(:), intent(inout), target :: array
real(kind=sp), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
end subroutine sp_radix_sort
module subroutine dp_radix_sort(array, work, reverse)
real(kind=dp), dimension(:), intent(inout), target :: array
real(kind=dp), dimension(:), intent(inout), target, optional :: work
logical, intent(in), optional :: reverse
end subroutine dp_radix_sort
end interface radix_sort
interface sort
!! Version: experimental
!!
!! The generic subroutine interface implementing the `SORT` algorithm, based
!! on the `introsort` of David Musser.
!! ([Specification](../page/specs/stdlib_sorting.html#sort-sorts-an-input-array))
#:for t1, t2, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
pure module subroutine ${name1}$_sort( array, reverse )
!! Version: experimental
!!
!! `${name1}$_sort( array[, reverse] )` sorts the input `ARRAY` of type `${t1}$`
!! using a hybrid sort based on the `introsort` of David Musser.
!! The algorithm is of order O(N Ln(N)) for all inputs.
!! Because it relies on `quicksort`, the coefficient of the O(N Ln(N))
!! behavior is small for random data compared to other sorting algorithms.
${t1}$, intent(inout) :: array(0:)
logical, intent(in), optional :: reverse
end subroutine ${name1}$_sort
#:endblock
#:endfor
end interface sort
interface sort_adjoint
!! Version: experimental
!!
!! The generic subroutine interface implementing the `SORT_ADJ` algorithm,
!! based on the `"Rust" sort` algorithm found in `slice.rs`
!! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159
!! but modified to return an array of indices that would provide a stable
!! sort of the rank one `ARRAY` input.
!! ([Specification](../page/specs/stdlib_sorting.html#sort_adjoint-creates-an-array-of-sorting-indices-for-an-input-array-while-also-sorting-the-array))
!!
!! The indices by default correspond to a
!! non-decreasing sort, but if the optional argument `REVERSE` is present
!! with a value of `.TRUE.` the indices correspond to a non-increasing sort.
#:for ti, tii, namei in IR_INDEX_TYPES_ALT_NAME
#:for t1, t2, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
module subroutine ${name1}$_${namei}$_sort_adjoint( array, adjoint_array, work, iwork, &
reverse )
!! Version: experimental
!!
!! `${name1}$_${namei}$_sort_adjoint( array, adjoint_array[, work, iwork, reverse] )` sorts
!! an input `ARRAY` of type `${t1}$`
!! using a hybrid sort based on the `"Rust" sort` algorithm found in `slice.rs`
!! and returns the sorted `ARRAY` and an array `INDEX` of indices in the
!! order that would sort the input `ARRAY` in the desired direction.
${t1}$, intent(inout) :: array(0:)
${ti}$, intent(inout) :: adjoint_array(0:)
${t2}$, intent(out), optional :: work(0:)
${ti}$, intent(out), optional :: iwork(0:)
logical, intent(in), optional :: reverse
end subroutine ${name1}$_${namei}$_sort_adjoint
#:endblock
#:endfor
#:endfor
end interface sort_adjoint
interface sort_index
!! Version: experimental
!!
!! The generic subroutine interface implementing the `SORT_INDEX` algorithm,
!! based on the `"Rust" sort` algorithm found in `slice.rs`
!! https://github.com/rust-lang/rust/blob/90eb44a5897c39e3dff9c7e48e3973671dcd9496/src/liballoc/slice.rs#L2159
!! but modified to return an array of indices that would provide a stable
!! sort of the rank one `ARRAY` input.
!! ([Specification](../page/specs/stdlib_sorting.html#sort_index-creates-an-array-of-sorting-indices-for-an-input-array-while-also-sorting-the-array))
!!
!! The indices by default correspond to a
!! non-decreasing sort, but if the optional argument `REVERSE` is present
!! with a value of `.TRUE.` the indices correspond to a non-increasing sort.
#:for ki, ti, namei in INT_INDEX_TYPES_ALT_NAME
#:for t1, t2, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
!> Version: experimental
!>
!> `${name1}$_sort_index_${namei}$( array, index[, work, iwork, reverse] )` sorts
!> an input `ARRAY` of type `${t1}$`
!> using a hybrid sort based on the `"Rust" sort` algorithm found in `slice.rs`
!> and returns the sorted `ARRAY` and an array `INDEX` of indices in the
!> order that would sort the input `ARRAY` in the desired direction.
module procedure ${name1}$_sort_index_${namei}$
#:endblock
#:endfor
#:endfor
end interface sort_index
contains
#:for ki, ti, namei in INT_INDEX_TYPES_ALT_NAME
#:for t1, t2, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
subroutine ${name1}$_sort_index_${namei}$( array, index, work, iwork, &
reverse )
!! Version: experimental
!!
!! `${name1}$_sort_index_${namei}$( array, index[, work, iwork, reverse] )` sorts
!! an input `ARRAY` of type `${t1}$`
!! using a hybrid sort based on the `"Rust" sort` algorithm found in `slice.rs`
!! and returns the sorted `ARRAY` and an array `INDEX` of indices in the
!! order that would sort the input `ARRAY` in the desired direction.
${t1}$, intent(inout) :: array(0:)
${ti}$, intent(out) :: index(0:)
${t2}$, intent(out), optional :: work(0:)
${ti}$, intent(out), optional :: iwork(0:)
logical, intent(in), optional :: reverse
integer(int_index) :: array_size, i
array_size = size(array, kind=int_index)
if ( array_size > huge(index)) then
error stop "Too many entries for the kind of index."
end if
if ( array_size > size(index, kind=int_index) ) then
error stop "Too many entries for the size of index."
end if
do i = 0, array_size-1
index(i) = int(i+1, kind=${ki}$)
end do
call sort_adjoint(array, index, work, iwork, reverse)
end subroutine ${name1}$_sort_index_${namei}$
#:endblock
#:endfor
#:endfor
end module stdlib_sorting
fortran-lang-stdlib-0ede301/src/sorting/CMakeLists.txt 0000664 0001750 0001750 00000001045 15135654166 023202 0 ustar alastair alastair set(sorting_fppFiles
)
set(sorting_cppFiles
stdlib_sorting.fypp
stdlib_sorting_ord_sort.fypp
stdlib_sorting_sort_adjoint.fypp
stdlib_sorting_sort.fypp
)
set(sorting_f90Files
stdlib_sorting_radix_sort.f90
)
configure_stdlib_target(${PROJECT_NAME}_sorting sorting_f90Files sorting_fppFiles sorting_cppFiles)
if(STDLIB_BITSETS)
target_link_libraries(${PROJECT_NAME}_sorting PUBLIC ${PROJECT_NAME}_bitsets)
endif()
target_link_libraries(${PROJECT_NAME}_sorting PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_strings)
fortran-lang-stdlib-0ede301/src/sorting/stdlib_sorting_sort.fypp 0000664 0001750 0001750 00000025126 15135654166 025445 0 ustar alastair alastair #include "macros.inc"
#:include "common.fypp"
#:set INT_TYPES_ALT_NAME = list(zip(INT_TYPES, INT_TYPES, INT_KINDS, INT_CPPS))
#:set REAL_TYPES_ALT_NAME = list(zip(REAL_TYPES, REAL_TYPES, REAL_KINDS, REAL_CPPS))
#:set STRING_TYPES_ALT_NAME = list(zip(STRING_TYPES, STRING_TYPES, STRING_KINDS, STRING_CPPS))
#:set CHAR_TYPES_ALT_NAME = list(zip(["character(len=*)"], ["character(len=len(array))"], ["char"], [""]))
#:set BITSETS_TYPES_ALT_NAME = list(zip(BITSETS_TYPES, BITSETS_TYPES, BITSETS_KINDS, BITSETS_CPPS))
#! For better code reuse in fypp, make lists that contain the input types,
#! with each having output types and a separate name prefix for subroutines
#! This approach allows us to have the same code for all input types.
#:set IRSCB_TYPES_ALT_NAME = INT_TYPES_ALT_NAME + REAL_TYPES_ALT_NAME + STRING_TYPES_ALT_NAME + CHAR_TYPES_ALT_NAME &
& + BITSETS_TYPES_ALT_NAME
#:set SIGN_NAME = ["increase", "decrease"]
#:set SIGN_TYPE = [">", "<"]
#:set SIGN_OPP_TYPE = ["<", ">"]
#:set SIGN_NAME_TYPE = list(zip(SIGN_NAME, SIGN_TYPE, SIGN_OPP_TYPE))
!! Licensing:
!!
!! This file is subjec† both to the Fortran Standard Library license, and
!! to additional licensing requirements as it contains translations of
!! other software.
!!
!! The Fortran Standard Library, including this file, is distributed under
!! the MIT license that should be included with the library's distribution.
!!
!! Copyright (c) 2021 Fortran stdlib developers
!!
!! 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 sellcopies 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.
!!
!! 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.
!!
!! The generic subroutine, `SORT`, is substantially a
!! translation to Fortran 2008, of the `introsort` of David Musser.
!! David Musser has given permission to include a variant of `introsort`
!! in the Fortran Standard Library under the MIT license provided
!! we cite:
!!
!! Musser, D.R., “Introspective Sorting and Selection Algorithms,”
!! Software—Practice and Experience, Vol. 27(8), 983–993 (August 1997).
!!
!! as the official source of the algorithm.
submodule(stdlib_sorting) stdlib_sorting_sort
!! This submodule implements the overloaded sorting subroutine `SORT`
!! that can be used to sort four kinds of `INTEGER` arrays and three kinds
!! of `REAL` arrays. Sorting is in order of increasing value, with the worst
!! case run time performance of `O(N Ln(N))`.
!!
!! `SORT` uses the `INTROSORT` sorting algorithm of David Musser,
!! http://www.cs.rpi.edu/~musser/gp/introsort.ps. `introsort` is a hybrid
!! unstable comparison algorithm combining `quicksort`, `insertion sort`, and
!! `heap sort`. While this algorithm is always O(N Ln(N)) it is relatively
!! fast on randomly ordered data, but inconsistent in performance on partly
!! sorted data, sometimes having `merge sort` performance, sometimes having
!! better than `quicksort` performance.
implicit none
contains
#:for t1, t2, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
pure module subroutine ${name1}$_sort( array, reverse )
${t1}$, intent(inout) :: array(0:)
logical, intent(in), optional :: reverse
if(optval(reverse, .false.))then
call ${name1}$_decrease_sort(array)
else
call ${name1}$_increase_sort(array)
endif
end subroutine ${name1}$_sort
#:endblock
#:endfor
#:for sname, signt, signoppt in SIGN_NAME_TYPE
#:for t1, t2, name1, cpp1 in IRSCB_TYPES_ALT_NAME
#:block generate_cpp(cpp_var=cpp1)
pure subroutine ${name1}$_${sname}$_sort( array )
! `${name1}$_${sname}$_sort( array )` sorts the input `ARRAY` of type `${t1}$`
! using a hybrid sort based on the `introsort` of David Musser. As with
! `introsort`, `${name1}$_${sname}$_sort( array )` is an unstable hybrid comparison
! algorithm using `quicksort` for the main body of the sort tree,
! supplemented by `insertion sort` for the outer branches, but if
! `quicksort` is converging too slowly the algorithm resorts
! to `heapsort`. The algorithm is of order O(N Ln(N)) for all inputs.
! Because it relies on `quicksort`, the coefficient of the O(N Ln(N))
! behavior is typically small compared to other sorting algorithms.
${t1}$, intent(inout) :: array(0:)
integer(int32) :: depth_limit
depth_limit = 2 * int( floor( log( real( size( array, kind=int_index), &
kind=dp) ) / log(2.0_dp) ), &
kind=int32 )
call introsort(array, depth_limit)
contains
pure recursive subroutine introsort( array, depth_limit )
! It devolves to `insertionsort` if the remaining number of elements
! is fewer than or equal to `INSERT_SIZE`, `heapsort` if the completion
! of the `quicksort` is too slow as estimated from `DEPTH_LIMIT`,
! otherwise sorting is done by a `quicksort`.
${t1}$, intent(inout) :: array(0:)
integer(int32), intent(in) :: depth_limit
integer(int_index), parameter :: insert_size = 16_int_index
integer(int_index) :: index
if ( size(array, kind=int_index) <= insert_size ) then
! May be best at the end of SORT processing the whole array
! See Musser, D.R., “Introspective Sorting and Selection
! Algorithms,” Software—Practice and Experience, Vol. 27(8),
! 983–993 (August 1997).
call insertion_sort( array )
else if ( depth_limit == 0 ) then
call heap_sort( array )
else
call partition( array, index )
call introsort( array(0:index-1), depth_limit-1 )
call introsort( array(index+1:), depth_limit-1 )
end if
end subroutine introsort
pure subroutine partition( array, index )
! quicksort partition using median of three.
${t1}$, intent(inout) :: array(0:)
integer(int_index), intent(out) :: index
${t2}$ :: u, v, w, x, y
integer(int_index) :: i, j
! Determine median of three and exchange it with the end.
u = array( 0 )
v = array( size(array, kind=int_index)/2-1 )
w = array( size(array, kind=int_index)-1 )
if ( (u ${signt}$ v) .neqv. (u ${signt}$ w) ) then
x = u
y = array(0)
array(0) = array( size( array, kind=int_index ) - 1 )
array( size( array, kind=int_index ) - 1 ) = y
else if ( (v ${signoppt}$ u) .neqv. (v ${signoppt}$ w) ) then
x = v
y = array(size( array, kind=int_index )/2-1)
array( size( array, kind=int_index )/2-1 ) = &
array( size( array, kind=int_index )-1 )
array( size( array, kind=int_index )-1 ) = y
else
x = w
end if
! Partition the array.
i = -1_int_index
do j = 0_int_index, size(array, kind=int_index)-2
if ( array(j) ${signoppt}$= x ) then
i = i + 1
y = array(i)
array(i) = array(j)
array(j) = y
end if
end do
y = array(i+1)
array(i+1) = array(size(array, kind=int_index)-1)
array(size(array, kind=int_index)-1) = y
index = i + 1
end subroutine partition
pure subroutine insertion_sort( array )
! Bog standard insertion sort.
${t1}$, intent(inout) :: array(0:)
integer(int_index) :: i, j
${t2}$ :: key
do j=1_int_index, size(array, kind=int_index)-1
key = array(j)
i = j - 1
do while( i >= 0 )
if ( array(i) ${signoppt}$= key ) exit
array(i+1) = array(i)
i = i - 1
end do
array(i+1) = key
end do
end subroutine insertion_sort
pure subroutine heap_sort( array )
! A bog standard heap sort
${t1}$, intent(inout) :: array(0:)
integer(int_index) :: i, heap_size
${t2}$ :: y
heap_size = size( array, kind=int_index )
! Build the max heap
do i = (heap_size-2)/2_int_index, 0_int_index, -1_int_index
call max_heapify( array, i, heap_size )
end do
do i = heap_size-1, 1_int_index, -1_int_index
! Swap the first element with the current final element
y = array(0)
array(0) = array(i)
array(i) = y
! Sift down using max_heapify
call max_heapify( array, 0_int_index, i )
end do
end subroutine heap_sort
pure recursive subroutine max_heapify( array, i, heap_size )
! Transform the array into a max heap
${t1}$, intent(inout) :: array(0:)
integer(int_index), intent(in) :: i, heap_size
integer(int_index) :: l, r, largest
${t2}$ :: y
largest = i
l = 2_int_index * i + 1_int_index
r = l + 1_int_index
if ( l < heap_size ) then
if ( array(l) ${signt}$ array(largest) ) largest = l
end if
if ( r < heap_size ) then
if ( array(r) ${signt}$ array(largest) ) largest = r
end if
if ( largest /= i ) then
y = array(i)
array(i) = array(largest)
array(largest) = y
call max_heapify( array, largest, heap_size )
end if
end subroutine max_heapify
end subroutine ${name1}$_${sname}$_sort
#:endblock
#:endfor
#:endfor
end submodule stdlib_sorting_sort
fortran-lang-stdlib-0ede301/src/stats/ 0000775 0001750 0001750 00000000000 15135654166 020113 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_distribution_exponential.fypp 0000664 0001750 0001750 00000032436 15135654166 030727 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
module stdlib_stats_distribution_exponential
use ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_kinds, only : sp, dp, xdp, qp, int32
use stdlib_random, only : dist_rand
use stdlib_stats_distribution_uniform, only : uni=>rvs_uniform
implicit none
private
integer :: ke(0:255)
real(dp) :: we(0:255), fe(0:255)
logical :: zig_exp_initialized = .false.
public :: rvs_exp
public :: pdf_exp
public :: cdf_exp
interface rvs_exp
!! Version experimental
!!
!! Exponential Distribution Random Variates
!! ([Specification](../page/specs/stdlib_stats_distribution_exponential.html#
!! rvs_exp-exponential-distribution-random-variates))
!!
module procedure rvs_exp_0_rsp !0 dummy variable
! new interfaces using loc and scale
#:for k1, t1 in RC_KINDS_TYPES
module procedure rvs_exp_${t1[0]}$${k1}$ !1 dummy variable
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
module procedure rvs_exp_array_${t1[0]}$${k1}$ !2 dummy variables
#:endfor
! original interfaces using lambda
#:for k1, t1 in RC_KINDS_TYPES
module procedure rvs_exp_lambda_${t1[0]}$${k1}$ !1 dummy variable
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
module procedure rvs_exp_array_lambda_${t1[0]}$${k1}$ !2 dummy variables
#:endfor
end interface rvs_exp
interface pdf_exp
!! Version experimental
!!
!! Exponential Distribution Probability Density Function
!! ([Specification](../page/specs/stdlib_stats_distribution_exponential.html#
!! pdf_exp-exponential-distribution-probability-density-function))
!!
! new interfaces using loc and scale
#:for k1, t1 in RC_KINDS_TYPES
module procedure pdf_exp_${t1[0]}$${k1}$
#:endfor
! original interfaces using lambda
#:for k1, t1 in RC_KINDS_TYPES
module procedure pdf_exp_lambda_${t1[0]}$${k1}$
#:endfor
end interface pdf_exp
interface cdf_exp
!! Version experimental
!!
!! Exponential Cumulative Distribution Function
!! ([Specification](../page/specs/stdlib_stats_distribution_exponential.html#
!! cdf_exp-exponential-distribution-cumulative-distribution-function))
!!
! new interfaces using loc and scale
#:for k1, t1 in RC_KINDS_TYPES
module procedure cdf_exp_${t1[0]}$${k1}$
#:endfor
! original interfaces using lambda
#:for k1, t1 in RC_KINDS_TYPES
module procedure cdf_exp_lambda_${t1[0]}$${k1}$
#:endfor
end interface cdf_exp
contains
impure subroutine zigset
! Marsaglia & Tsang generator for random normals & random exponentials.
! Translated from C by Alan Miller (amiller@bigpond.net.au)
!
! Marsaglia, G. & Tsang, W.W. (2000) 'The ziggurat method for generating
! random variables', J. Statist. Software, v5(8).
!
! This is an electronic journal which can be downloaded from:
! http://www.jstatsoft.org/v05/i08
!
! Latest version - 1 January 2001
!
real(dp), parameter :: M2 = 2147483648.0_dp, ve = 0.003949659822581572_dp
real(dp), parameter :: ONE = 1.0_dp
real(dp) :: de, te, q
integer :: i
de = 7.697117470131487_dp
te = de
! tables for random exponentials
q = ve * exp(de)
ke(0) = int((de / q) * M2, kind = int32)
ke(1) = 0
we(0) = q / M2
we(255) = de / M2
fe(0) = ONE
fe(255) = exp(- de)
do i = 254, 1, -1
de = -log(ve / de + exp(- de))
ke(i+1) = int(M2 * (de / te), kind = int32)
te = de
fe(i) = exp(- de)
we(i) = de / M2
end do
zig_exp_initialized = .true.
end subroutine zigset
#:for k1, t1 in REAL_KINDS_TYPES
impure function rvs_exp_0_${t1[0]}$${k1}$( ) result(res)
!
! Standard exponential random variate (lambda=1; scale=1/lambda=1)
!
${t1}$ :: res, x
${t1}$, parameter :: r = 7.69711747013104972_${k1}$
integer :: jz, iz
if(.not. zig_exp_initialized ) call zigset
iz = 0
jz = dist_rand(1_int32) ! 32bit random integer
iz = iand( jz, 255 ) ! random integer in [0, 255]
if( abs( jz ) < ke(iz) ) then
res = abs(jz) * we(iz)
else
L1: do
if( iz == 0 ) then
res = r - log( uni(1.0_${k1}$) )
exit L1
end if
x = abs( jz ) * we(iz)
if(fe(iz) + uni(1.0_${k1}$) * (fe(iz-1) - fe(iz)) < exp(-x)) then
res = x
exit L1
end if
jz = dist_rand(1_int32)
iz = iand( jz, 255 )
if( abs( jz ) < ke(iz) ) then
res = abs( jz ) * we(iz)
exit L1
end if
end do L1
endif
end function rvs_exp_0_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure elemental function rvs_exp_${t1[0]}$${k1}$(loc, scale) result(res)
!
! Exponential distributed random variate
!
${t1}$, intent(in) :: loc, scale
${t1}$ :: res
if (scale <= 0._${k1}$) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
else
res = rvs_exp_0_${t1[0]}$${k1}$( )
res = res * scale + loc
end if
end function rvs_exp_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure elemental function rvs_exp_${t1[0]}$${k1}$(loc, scale) result(res)
${t1}$, intent(in) :: loc, scale
${t1}$ :: res
real(${k1}$) :: tr, ti
tr = rvs_exp_r${k1}$(loc%re, scale%re)
ti = rvs_exp_r${k1}$(loc%im, scale%im)
res = cmplx(tr, ti, kind=${k1}$)
end function rvs_exp_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure function rvs_exp_array_${t1[0]}$${k1}$(loc, scale, array_size) result(res)
${t1}$, intent(in) :: loc, scale
integer, intent(in) :: array_size
${t1}$ :: res(array_size), x, re
${t1}$, parameter :: r = 7.69711747013104972_${k1}$
integer :: jz, iz, i
if (scale <= 0._${k1}$) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
if(.not. zig_exp_initialized) call zigset
do i = 1, array_size
iz = 0
jz = dist_rand(1_int32)
iz = iand( jz, 255 )
if( abs( jz ) < ke(iz) ) then
re = abs(jz) * we(iz)
else
L1: do
if( iz == 0 ) then
re = r - log( uni(1.0_${k1}$) )
exit L1
end if
x = abs( jz ) * we(iz)
if(fe(iz) + uni(1.0_${k1}$)*(fe(iz-1)-fe(iz)) < exp(-x)) then
re = x
exit L1
end if
jz = dist_rand(1_int32)
iz = iand( jz, 255 )
if( abs( jz ) < ke(iz) ) then
re = abs( jz ) * we(iz)
exit L1
end if
end do L1
endif
res(i) = re * scale + loc
end do
end function rvs_exp_array_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure function rvs_exp_array_${t1[0]}$${k1}$(loc, scale, array_size) result(res)
${t1}$, intent(in) :: loc, scale
integer, intent(in) :: array_size
${t1}$ :: res(array_size)
integer :: i
real(${k1}$) :: tr, ti
do i = 1, array_size
tr = rvs_exp_r${k1}$(loc%re, scale%re)
ti = rvs_exp_r${k1}$(loc%im, scale%im)
res(i) = cmplx(tr, ti, kind=${k1}$)
end do
end function rvs_exp_array_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function pdf_exp_${t1[0]}$${k1}$(x, loc, scale) result(res)
!
! Exponential Distribution Probability Density Function
!
${t1}$, intent(in) :: x, loc, scale
real(${k1}$) :: res
if (scale <= 0._${k1}$) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
else if (x < loc) then
res = 0._${k1}$
else
res = exp(- (x - loc) / scale) / scale
end if
end function pdf_exp_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function pdf_exp_${t1[0]}$${k1}$(x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
real(${k1}$) :: res
res = pdf_exp_r${k1}$(x%re, loc%re, scale%re)
res = res * pdf_exp_r${k1}$(x%im, loc%im, scale%im)
end function pdf_exp_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function cdf_exp_${t1[0]}$${k1}$(x, loc, scale) result(res)
!
! Exponential Distribution Cumulative Distribution Function
!
${t1}$, intent(in) :: x, loc, scale
real(${k1}$) :: res
if (scale <= 0._${k1}$) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
else if (x < loc) then
res = 0._${k1}$
else
res = 1.0_${k1}$ - exp(- (x - loc) / scale)
end if
end function cdf_exp_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function cdf_exp_${t1[0]}$${k1}$(x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
real(${k1}$) :: res
res = cdf_exp_r${k1}$(x%re, loc%re, scale%re)
res = res * cdf_exp_r${k1}$(x%im, loc%im, scale%im)
end function cdf_exp_${t1[0]}$${k1}$
#:endfor
!
! below: wrapper functions for interfaces using lambda (for backward compatibility)
!
#:for k1, t1 in REAL_KINDS_TYPES
impure elemental function rvs_exp_lambda_${t1[0]}$${k1}$(lambda) result(res)
!
! Exponential distributed random variate
!
${t1}$, intent(in) :: lambda
${t1}$ :: res
res = rvs_exp_${t1[0]}$${k1}$(0._${k1}$, 1.0_${k1}$/lambda)
end function rvs_exp_lambda_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure elemental function rvs_exp_lambda_${t1[0]}$${k1}$(lambda) result(res)
${t1}$, intent(in) :: lambda
${t1}$ :: res
real(${k1}$) :: tr, ti
tr = rvs_exp_r${k1}$(0._${k1}$, 1.0_${k1}$/lambda%re)
ti = rvs_exp_r${k1}$(0._${k1}$, 1.0_${k1}$/lambda%im)
res = cmplx(tr, ti, kind=${k1}$)
end function rvs_exp_lambda_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure function rvs_exp_array_lambda_${t1[0]}$${k1}$(lambda, array_size) result(res)
${t1}$, intent(in) :: lambda
integer, intent(in) :: array_size
${t1}$ :: res(array_size)
res = rvs_exp_array_${t1[0]}$${k1}$(0._${k1}$, 1.0_${k1}$/lambda, array_size)
end function rvs_exp_array_lambda_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure function rvs_exp_array_lambda_${t1[0]}$${k1}$(lambda, array_size) result(res)
${t1}$, intent(in) :: lambda
integer, intent(in) :: array_size
${t1}$ :: res(array_size)
integer :: i
real(${k1}$) :: tr, ti
do i = 1, array_size
tr = rvs_exp_r${k1}$(0._${k1}$, 1.0_${k1}$/lambda%re)
ti = rvs_exp_r${k1}$(0._${k1}$, 1.0_${k1}$/lambda%im)
res(i) = cmplx(tr, ti, kind=${k1}$)
end do
end function rvs_exp_array_lambda_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function pdf_exp_lambda_${t1[0]}$${k1}$(x, lambda) result(res)
!
! Exponential Distribution Probability Density Function
!
${t1}$, intent(in) :: x, lambda
real(${k1}$) :: res
res = pdf_exp_${t1[0]}$${k1}$(x, 0._${k1}$, 1.0_${k1}$/lambda)
end function pdf_exp_lambda_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function pdf_exp_lambda_${t1[0]}$${k1}$(x, lambda) result(res)
${t1}$, intent(in) :: x, lambda
real(${k1}$) :: res
res = pdf_exp_r${k1}$(x%re, 0._${k1}$, 1.0_${k1}$/lambda%re)
res = res * pdf_exp_r${k1}$(x%im, 0._${k1}$, 1.0_${k1}$/lambda%im)
end function pdf_exp_lambda_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function cdf_exp_lambda_${t1[0]}$${k1}$(x, lambda) result(res)
!
! Exponential Distribution Cumulative Distribution Function
!
${t1}$, intent(in) :: x, lambda
real(${k1}$) :: res
res = cdf_exp_${t1[0]}$${k1}$(x, 0._${k1}$, 1.0_${k1}$/lambda)
end function cdf_exp_lambda_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function cdf_exp_lambda_${t1[0]}$${k1}$(x, lambda) result(res)
${t1}$, intent(in) :: x, lambda
real(${k1}$) :: res
res = cdf_exp_r${k1}$(x%re, 0._${k1}$, 1.0_${k1}$/lambda%re)
res = res * cdf_exp_r${k1}$(x%im, 0._${k1}$, 1.0_${k1}$/lambda%im)
end function cdf_exp_lambda_${t1[0]}$${k1}$
#:endfor
end module stdlib_stats_distribution_exponential
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_moment_all.fypp 0000664 0001750 0001750 00000006732 15135654166 025731 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set REDRANKS = range(2, MAXRANK + 1)
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_stats) stdlib_stats_moment_all
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_error, only: error_stop
use stdlib_optval, only: optval
implicit none
contains
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("moment_all",rank, t1, k1)
module function ${RName}$(x, order, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
${t1}$, intent(in), optional :: center
logical, intent(in), optional :: mask
${t1}$ :: res
real(${k1}$) :: n
${t1}$ :: center_
if (.not.optval(mask, .true.)) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
n = real(size(x, kind = int64), ${k1}$)
if (present(center)) then
center_ = center
else
center_ = mean(x)
end if
res = sum((x - center_)**order) / n
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("moment_all",rank, t1, k1, 'dp')
module function ${RName}$(x, order, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
real(dp), intent(in), optional :: center
logical, intent(in), optional :: mask
real(dp) :: res
real(dp) :: n
real(dp) :: center_
if (.not.optval(mask, .true.)) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
n = real(size(x, kind = int64), dp)
if (present(center)) then
center_ = center
else
center_ = mean(x)
end if
res = sum((real(x, dp) - center_)**order) / n
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("moment_mask_all",rank, t1, k1)
module function ${RName}$(x, order, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
${t1}$, intent(in), optional :: center
logical, intent(in) :: mask${ranksuffix(rank)}$
${t1}$ :: res
real(${k1}$) :: n
${t1}$ :: center_
n = real(count(mask, kind = int64), ${k1}$)
if (present(center)) then
center_ = center
else
center_ = mean(x, mask)
end if
res = sum((x - center_)**order, mask) / n
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("moment_mask_all",rank, t1, k1, 'dp')
module function ${RName}$(x, order, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
real(dp),intent(in), optional :: center
logical, intent(in) :: mask${ranksuffix(rank)}$
real(dp) :: res
real(dp) :: n
real(dp) :: center_
n = real(count(mask, kind = int64), dp)
if (present(center)) then
center_ = center
else
center_ = mean(x, mask)
end if
res = sum((real(x, dp) - center_)**order, mask) / n
end function ${RName}$
#:endfor
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_corr.fypp 0000664 0001750 0001750 00000022133 15135654166 024540 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_stats) stdlib_stats_corr
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_error, only: error_stop
use stdlib_linalg, only: diag
use stdlib_optval, only: optval
implicit none
contains
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("corr",1, t1, k1)
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
real(${k1}$) :: res
if (.not.optval(mask, .true.) .or. size(x) < 2) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
res = 1
end function ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("corr",1, t1, k1, 'dp')
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
real(dp) :: res
if (.not.optval(mask, .true.) .or. size(x) < 2) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
res = 1
end function ${RName}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("corr_mask",1, t1, k1)
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in) :: mask(:)
real(${k1}$) :: res
if (count(mask) < 2) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
res = 1
end function ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("corr_mask",1, t1, k1, 'dp')
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in) :: mask(:)
real(dp) :: res
if (count(mask) < 2) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
res = 1
end function ${RName}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("corr",2, t1, k1)
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:, :)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
${t1}$ :: res(merge(size(x, 1), size(x, 2), mask = 1 rvs_uniform
implicit none
private
real(dp), parameter :: HALF = 0.5_dp, ONE = 1.0_dp, TWO = 2.0_dp
integer :: kn(0:127)
real(dp) :: wn(0:127), fn(0:127)
logical :: zig_norm_initialized = .false.
public :: rvs_normal
public :: pdf_normal
public :: cdf_normal
interface rvs_normal
!! version: experimental
!!
!! Normal Distribution Random Variates
!! ([Specification](../page/specs/stdlib_stats_distribution_normal.html#
!! rvs_normal-normal-distribution-random-variates))
!!
module procedure rvs_norm_0_rsp !0 dummy variable
#:for k1, t1 in RC_KINDS_TYPES
module procedure rvs_norm_${t1[0]}$${k1}$ !2 dummy variables
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
module procedure rvs_norm_array_${t1[0]}$${k1}$ !3 dummy variables
module procedure rvs_norm_array_default_${t1[0]}$${k1}$ !array_size, mold (mold optional for real(dp) only)
#:endfor
end interface rvs_normal
interface pdf_normal
!! version: experimental
!!
!! Normal Distribution Probability Density Function
!! ([Specification](../page/specs/stdlib_stats_distribution_normal.html#
!! pdf_normal-normal-distribution-probability-density-function))
!!
#:for k1, t1 in RC_KINDS_TYPES
module procedure pdf_norm_${t1[0]}$${k1}$
#:endfor
end interface pdf_normal
interface cdf_normal
!! version: experimental
!!
!! Normal Distribution Cumulative Distribution Function
!! ([Specification](../page/specs/stdlib_stats_distribution_normal.html#
!! cdf_normal-normal-distribution-cumulative-distribution-function))
!!
#:for k1, t1 in RC_KINDS_TYPES
module procedure cdf_norm_${t1[0]}$${k1}$
#:endfor
end interface cdf_normal
contains
impure subroutine zigset
! Marsaglia & Tsang generator for random normals & random exponentials.
! Translated from C by Alan Miller (amiller@bigpond.net.au), released as public
! domain (https://jblevins.org/mirror/amiller/)
!
! Marsaglia, G. & Tsang, W.W. (2000) `The ziggurat method for generating
! random variables', J. Statist. Software, v5(8).
!
! This is an electronic journal which can be downloaded from:
! http://www.jstatsoft.org/v05/i08
!
! Latest version - 1 January 2001
!
real(dp), parameter :: M1 = 2147483648.0_dp, vn = 0.00991256303526217_dp
real(dp) :: dn, tn, q
integer :: i
dn = 3.442619855899_dp
tn = dn
!tables for random normals
q = vn*exp(HALF*dn*dn)
kn(0) = int((dn/q)*M1, kind=int32)
kn(1) = 0
wn(0) = q/M1
wn(127) = dn/M1
fn(0) = ONE
fn(127) = exp(-HALF*dn*dn)
do i = 126, 1, -1
dn = sqrt(-TWO*log(vn/dn + exp(-HALF*dn*dn)))
kn(i + 1) = int((dn/tn)*M1, kind=int32)
tn = dn
fn(i) = exp(-HALF*dn*dn)
wn(i) = dn/M1
end do
zig_norm_initialized = .true.
end subroutine zigset
#:for k1, t1 in REAL_KINDS_TYPES
impure function rvs_norm_0_${t1[0]}$${k1}$ () result(res)
!
! Standard normal random variate (0,1)
!
${t1}$ :: res
${t1}$, parameter :: r = 3.442619855899_${k1}$, rr = 1.0_${k1}$/r
${t1}$ :: x, y
integer :: hz, iz
if (.not. zig_norm_initialized) call zigset
iz = 0
hz = dist_rand(1_int32) !32bit random integer
iz = iand(hz, 127) !random integer in [0, 127]
if (abs(hz) < kn(iz)) then
res = hz*wn(iz)
else
L1: do
L2: if (iz == 0) then
do
x = -log(uni(1.0_${k1}$))*rr
y = -log(uni(1.0_${k1}$))
if (y + y >= x*x) exit
end do
res = r + x
if (hz <= 0) res = -res
exit L1
end if L2
x = hz*wn(iz)
if (fn(iz) + uni(1.0_${k1}$)*(fn(iz - 1) - fn(iz)) < &
exp(-HALF*x*x)) then
res = x
exit L1
end if
hz = dist_rand(1_int32)
iz = iand(hz, 127)
if (abs(hz) < kn(iz)) then
res = hz*wn(iz)
exit L1
end if
end do L1
end if
end function rvs_norm_0_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure elemental &
function rvs_norm_${t1[0]}$${k1}$ (loc, scale) result(res)
!
! Normal random variate (loc, scale)
!
${t1}$, intent(in) :: loc, scale
${t1}$ :: res
if (scale <= 0._${k1}$) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
else
res = rvs_norm_0_${t1[0]}$${k1}$ ()
res = res*scale + loc
end if
end function rvs_norm_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure elemental function rvs_norm_${t1[0]}$${k1}$ (loc, scale) result(res)
!
! Normally distributed complex. The real part and imaginary part are &
! independent of each other.
!
${t1}$, intent(in) :: loc, scale
${t1}$ :: res
real(${k1}$) :: tr, ti
tr = rvs_norm_r${k1}$ (loc%re, scale%re)
ti = rvs_norm_r${k1}$ (loc%im, scale%im)
res = cmplx(tr, ti, kind=${k1}$)
end function rvs_norm_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure function rvs_norm_array_${t1[0]}$${k1}$ (loc, scale, array_size) result(res)
${t1}$, intent(in) :: loc, scale
integer, intent(in) :: array_size
${t1}$ :: res(array_size)
${t1}$, parameter :: r = 3.442619855899_${k1}$, rr = 1.0_${k1}$/r
${t1}$ :: x, y, re
integer :: hz, iz, i
if (.not. zig_norm_initialized) call zigset
if (scale <= 0._${k1}$) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
do i = 1, array_size
iz = 0
hz = dist_rand(1_int32)
iz = iand(hz, 127)
if (abs(hz) < kn(iz)) then
re = hz*wn(iz)
else
L1: do
L2: if (iz == 0) then
do
x = -log(uni(1.0_${k1}$))*rr
y = -log(uni(1.0_${k1}$))
if (y + y >= x*x) exit
end do
re = r + x
if (hz <= 0) re = -re
exit L1
end if L2
x = hz*wn(iz)
if (fn(iz) + uni(1.0_${k1}$)*(fn(iz - 1) - fn(iz)) < &
exp(-HALF*x*x)) then
re = x
exit L1
end if
hz = dist_rand(1_int32)
iz = iand(hz, 127)
if (abs(hz) < kn(iz)) then
re = hz*wn(iz)
exit L1
end if
end do L1
end if
res(i) = re*scale + loc
end do
end function rvs_norm_array_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure function rvs_norm_array_default_${t1[0]}$${k1}$ (array_size, mold) result(res)
!
! Standard normal array random variate with default loc=0, scale=1
! The mold argument is used only to determine the type and is not referenced
!
integer, intent(in) :: array_size
${t1}$, intent(in) #{if t1 == 'real(dp)'}#, optional #{endif}#:: mold
${t1}$ :: res(array_size)
res = rvs_norm_array_${t1[0]}$${k1}$ (0.0_${k1}$, 1.0_${k1}$, array_size)
end function rvs_norm_array_default_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure function rvs_norm_array_${t1[0]}$${k1}$ (loc, scale, array_size) result(res)
${t1}$, intent(in) :: loc, scale
integer, intent(in) :: array_size
integer :: i
${t1}$ :: res(array_size)
real(${k1}$) :: tr, ti
do i = 1, array_size
tr = rvs_norm_r${k1}$ (loc%re, scale%re)
ti = rvs_norm_r${k1}$ (loc%im, scale%im)
res(i) = cmplx(tr, ti, kind=${k1}$)
end do
end function rvs_norm_array_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure function rvs_norm_array_default_${t1[0]}$${k1}$ (array_size, mold) result(res)
!
! Standard normal complex array random variate with default loc=0, scale=1
! The mold argument is used only to determine the type and is not referenced
!
integer, intent(in) :: array_size
${t1}$, intent(in) :: mold
${t1}$ :: res(array_size)
! Call the full procedure with default loc=(0,0), scale=(1,1)
res = rvs_norm_array_${t1[0]}$${k1}$ (cmplx(0.0_${k1}$, 0.0_${k1}$, kind=${k1}$), &
cmplx(1.0_${k1}$, 1.0_${k1}$, kind=${k1}$), &
array_size)
end function rvs_norm_array_default_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function pdf_norm_${t1[0]}$${k1}$ (x, loc, scale) result(res)
!
! Normal distribution probability density function
!
${t1}$, intent(in) :: x, loc, scale
${t1}$ :: res
${t1}$, parameter :: sqrt_2_pi = sqrt(2.0_${k1}$*acos(-1.0_${k1}$))
if (scale <= 0._${k1}$) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
else
res = exp(-0.5_${k1}$*((x - loc)/scale)*(x - loc)/scale)/ &
(sqrt_2_Pi*scale)
end if
end function pdf_norm_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function pdf_norm_${t1[0]}$${k1}$ (x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
real(${k1}$) :: res
res = pdf_norm_r${k1}$ (x%re, loc%re, scale%re)
res = res*pdf_norm_r${k1}$ (x%im, loc%im, scale%im)
end function pdf_norm_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function cdf_norm_${t1[0]}$${k1}$ (x, loc, scale) result(res)
!
! Normal distribution cumulative distribution function
!
${t1}$, intent(in) :: x, loc, scale
${t1}$ :: res
${t1}$, parameter :: sqrt_2 = sqrt(2.0_${k1}$)
if (scale <= 0._${k1}$) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
else
res = erfc(-(x - loc)/(scale*sqrt_2))/2.0_${k1}$
end if
end function cdf_norm_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function cdf_norm_${t1[0]}$${k1}$ (x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
real(${k1}$) :: res
res = cdf_norm_r${k1}$ (x%re, loc%re, scale%re)
res = res*cdf_norm_r${k1}$ (x%im, loc%im, scale%im)
end function cdf_norm_${t1[0]}$${k1}$
#:endfor
end module stdlib_stats_distribution_normal
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_cov.fypp 0000664 0001750 0001750 00000022570 15135654166 024367 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_stats) stdlib_stats_cov
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_error, only: error_stop
use stdlib_optval, only: optval
implicit none
contains
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("cov",1, t1, k1)
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
logical, intent(in), optional :: corrected
real(${k1}$) :: res
if (.not.optval(mask, .true.)) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
res = var(x, dim, corrected = optval(corrected, .true.))
end function ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("cov",1, t1, k1, 'dp')
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
logical, intent(in), optional :: corrected
real(dp) :: res
if (.not.optval(mask, .true.)) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
res = var(x, dim, corrected = optval(corrected, .true.))
end function ${RName}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("cov_mask",1, t1, k1)
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in) :: mask(:)
logical, intent(in), optional :: corrected
real(${k1}$) :: res
res = var(x, dim, mask, corrected = optval(corrected, .true.))
end function ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("cov_mask",1, t1, k1, 'dp')
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in) :: mask(:)
logical, intent(in), optional :: corrected
real(dp) :: res
res = var(x, dim, mask, corrected = optval(corrected, .true.))
end function ${RName}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("cov",2, t1, k1)
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x(:, :)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
logical, intent(in), optional :: corrected
${t1}$ :: res(merge(size(x, 1), size(x, 2), mask = 1 0))
end do
end do
case(2)
do i = 1, size(res, 2)
do j = 1, size(res, 1)
mask_ = mask(i, :) .and. mask(j, :)
centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),&
#:if t1[0] == 'r'
0._${k1}$,&
#:else
cmplx(0,0,kind=${k1}$),&
#:endif
mask_)
centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),&
#:if t1[0] == 'r'
0._${k1}$,&
#:else
cmplx(0,0,kind=${k1}$),&
#:endif
mask_)
n = count(mask_)
res(j, i) = dot_product( centeri_, centerj_)&
/ (n - merge(1, 0,&
optval(corrected, .true.) .and. n > 0))
end do
end do
case default
call error_stop("ERROR (cov): wrong dimension")
end select
end function ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("cov_mask",2, t1, k1, 'dp')
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x(:, :)
integer, intent(in) :: dim
logical, intent(in) :: mask(:,:)
logical, intent(in), optional :: corrected
real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1 0))
end do
end do
case(2)
do i = 1, size(res, 2)
do j = 1, size(res, 1)
mask_ = mask(i, :) .and. mask(j, :)
centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),0._dp, mask_)
centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),0._dp, mask_)
n = count(mask_)
res(j, i) = dot_product( centeri_, centerj_)&
/ (n - merge(1, 0,&
optval(corrected, .true.) .and. n > 0))
end do
end do
case default
call error_stop("ERROR (cov): wrong dimension")
end select
end function ${RName}$
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats.fypp 0000664 0001750 0001750 00000056044 15135654166 023523 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set REDRANKS = range(2, MAXRANK + 1)
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set IR_KINDS_TYPES_OUTPUT = list(zip(INT_KINDS,INT_TYPES, ['dp']*len(INT_KINDS))) + list(zip(REAL_KINDS, REAL_TYPES, REAL_KINDS))
module stdlib_stats
!! Provides support for various statistical methods. This includes currently
!! descriptive statistics
!! ([Specification](../page/specs/stdlib_stats.html))
use stdlib_kinds, only: sp, dp, xdp, qp, &
int8, int16, int32, int64
implicit none
private
! Public API
public :: corr, cov, mean, median, moment, var
interface corr
!! version: experimental
!!
!! Pearson correlation of array elements
!! ([Specification](../page/specs/stdlib_stats.html#corr-pearson-correlation-of-array-elements))
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("corr",1, t1, k1)
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
real(${k1}$) :: res
end function ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("corr",1, t1, k1, 'dp')
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
real(dp) :: res
end function ${RName}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("corr_mask",1, t1, k1)
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in) :: mask(:)
real(${k1}$) :: res
end function ${RName}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:set RName = rname("corr_mask",1, t1, k1, 'dp')
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:)
integer, intent(in) :: dim
logical, intent(in) :: mask(:)
real(dp) :: res
end function ${RName}$
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:set RName = rname("corr",2, t1, k1)
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x(:, :)
integer, intent(in) :: dim
logical, intent(in), optional :: mask
${t1}$ :: res(merge(size(x, 1), size(x, 2), mask = 1 1
#:for fj in range(1, rank+1)
integer :: j${fj}$
#:endfor
#:endif
${t1}$ :: val, val1
${t1}$, allocatable :: x_tmp(:)
if (.not.optval(mask, .true.) .or. size(x) == 0) then
res = ieee_value(1._${o1}$, ieee_quiet_nan)
return
end if
n = size(x, dim)
c = floor( (n + 1) / 2._${o1}$ )
allocate(x_tmp(n))
select case(dim)
#:for fi in range(1, rank+1)
case(${fi}$)
! Loop over every dimension of the array except "dim"
#:for fj in list(range(1, fi)) + list(range(fi+1, rank+1))
do j${fj}$ = 1, size(x, ${fj}$)
#:endfor
x_tmp(:) = x${select_subvector('j', rank, fi)}$
#:if t1[0] == 'r'
if (any(ieee_is_nan(x_tmp))) then
res${reduce_subvector('j', rank, fi)}$ = &
ieee_value(1._${o1}$, ieee_quiet_nan)
#:if fi == 1
return
#:else
cycle
#:endif
end if
#:endif
call select(x_tmp, c, val)
if (mod(n, 2) == 0) then
val1 = minval(x_tmp(c+1:n))
res${reduce_subvector('j', rank, fi)}$ = &
#:if t1[0] == 'r'
(val + val1) / 2._${o1}$
#:else
(real(val, kind=${o1}$) + real(val1, kind=${o1}$)) / 2._${o1}$
#:endif
else
res${reduce_subvector('j', rank, fi)}$ = val
end if
#:for fj in range(1, rank)
end do
#:endfor
#:endfor
case default
call error_stop("ERROR (median): wrong dimension")
end select
end function ${name}$
#:endfor
#:endfor
#:for k1, t1, o1 in IR_KINDS_TYPES_OUTPUT
#:for rank in RANKS
#:set name = rname('median_all_mask',rank, t1, k1, o1)
module function ${name}$(x, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in) :: mask${ranksuffix(rank)}$
real(${o1}$) :: res
integer(kind = int64) :: c, n
${t1}$ :: val, val1
${t1}$, allocatable :: x_tmp(:)
if (any(shape(x) .ne. shape(mask))) then
call error_stop("ERROR (median): shapes of x and mask are different")
end if
#:if t1[0] == 'r'
if (any(ieee_is_nan(x))) then
res = ieee_value(1._${o1}$, ieee_quiet_nan)
return
end if
#:endif
x_tmp = pack(x, mask)
n = size(x_tmp, kind=int64)
if (n == 0) then
res = ieee_value(1._${o1}$, ieee_quiet_nan)
return
end if
c = floor( (n + 1) / 2._${o1}$, kind=int64)
call select(x_tmp, c, val)
if (mod(n, 2_int64) == 0) then
val1 = minval(x_tmp(c+1:n))
#:if t1[0] == 'r'
res = (val + val1) / 2._${o1}$
#:else
res = (real(val, kind=${o1}$) + real(val1, kind=${o1}$)) / 2._${o1}$
#:endif
else if (mod(n, 2_int64) == 1) then
res = val
end if
end function ${name}$
#:endfor
#:endfor
#:for k1, t1, o1 in IR_KINDS_TYPES_OUTPUT
#:for rank in RANKS
#:set name = rname('median_mask',rank, t1, k1, o1)
module function ${name}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in) :: mask${ranksuffix(rank)}$
real(${o1}$) :: res${reduced_shape('x', rank, 'dim')}$
integer(kind = int64) :: c, n
#:if rank > 1
#:for fj in range(1, rank+1)
integer :: j${fj}$
#:endfor
#:endif
${t1}$ :: val, val1
${t1}$, allocatable :: x_tmp(:)
if (any(shape(x) .ne. shape(mask))) then
call error_stop("ERROR (median): shapes of x and mask are different")
end if
select case(dim)
#:for fi in range(1, rank+1)
case(${fi}$)
! Loop over every dimension of the array except "dim"
#:for fj in list(range(1, fi)) + list(range(fi+1, rank+1))
do j${fj}$ = 1, size(x, ${fj}$)
#:endfor
x_tmp = pack(x${select_subvector('j', rank, fi)}$, &
mask${select_subvector('j', rank, fi)}$)
#:if t1[0] == 'r'
if (any(ieee_is_nan(x_tmp))) then
res${reduce_subvector('j', rank, fi)}$ = &
ieee_value(1._${o1}$, ieee_quiet_nan)
#:if rank == 1
return
#:else
cycle
#:endif
end if
#:endif
n = size(x_tmp, kind=int64)
if (n == 0) then
res${reduce_subvector('j', rank, fi)}$ = &
ieee_value(1._${o1}$, ieee_quiet_nan)
return
end if
c = floor( (n + 1) / 2._${o1}$, kind=int64 )
call select(x_tmp, c, val)
if (mod(n, 2_int64) == 0) then
val1 = minval(x_tmp(c+1:n))
res${reduce_subvector('j', rank, fi)}$ = &
#:if t1[0] == 'r'
(val + val1) / 2._${o1}$
#:else
(real(val, kind=${o1}$) + real(val1, kind=${o1}$)) / 2._${o1}$
#:endif
else if (mod(n, 2_int64) == 1) then
res${reduce_subvector('j', rank, fi)}$ = val
end if
deallocate(x_tmp)
#:for fj in range(1, rank)
end do
#:endfor
#:endfor
case default
call error_stop("ERROR (median): wrong dimension")
end select
end function ${name}$
#:endfor
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/stats/CMakeLists.txt 0000664 0001750 0001750 00000001421 15135654166 022651 0 ustar alastair alastair set(stats_cppFiles
)
set(stats_fppFiles
stdlib_random.fypp
stdlib_stats_corr.fypp
stdlib_stats_cov.fypp
stdlib_stats_distribution_exponential.fypp
stdlib_stats_distribution_normal.fypp
stdlib_stats_distribution_uniform.fypp
stdlib_stats.fypp
stdlib_stats_mean.fypp
stdlib_stats_median.fypp
stdlib_stats_moment_all.fypp
stdlib_stats_moment.fypp
stdlib_stats_moment_mask.fypp
stdlib_stats_moment_scalar.fypp
stdlib_stats_var.fypp
)
set(stats_f90Files
)
configure_stdlib_target(${PROJECT_NAME}_stats stats_f90Files stats_fppFiles stats_cppFiles)
target_link_libraries(${PROJECT_NAME}_stats PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_linalg_core ${PROJECT_NAME}_linalg ${PROJECT_NAME}_selection ${PROJECT_NAME}_strings)
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_var.fypp 0000664 0001750 0001750 00000021006 15135654166 024361 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_stats) stdlib_stats_var
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_error, only: error_stop
use stdlib_optval, only: optval
implicit none
contains
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("var_all",rank, t1, k1)
module function ${RName}$(x, mask, corrected) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in), optional :: mask
logical, intent(in), optional :: corrected
real(${k1}$) :: res
real(${k1}$) :: n
${t1}$ :: mean
if (.not.optval(mask, .true.)) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
n = real(size(x, kind = int64), ${k1}$)
mean = sum(x) / n
#:if t1[0] == 'r'
res = sum((x - mean)**2) / (n - merge(1, 0 , optval(corrected, .true.)))
#:else
res = sum(abs(x - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))
#:endif
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("var_all",rank, t1, k1, 'dp')
module function ${RName}$(x, mask, corrected) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in), optional :: mask
logical, intent(in), optional :: corrected
real(dp) :: res
real(dp) :: n, mean
if (.not.optval(mask, .true.)) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
n = real(size(x, kind = int64), dp)
mean = sum(real(x, dp)) / n
res = sum((real(x, dp) - mean)**2) / (n - merge(1, 0, optval(corrected, .true.)))
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("var",rank, t1, k1)
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in), optional :: mask
logical, intent(in), optional :: corrected
real(${k1}$) :: res${reduced_shape('x', rank, 'dim')}$
integer :: i
real(${k1}$) :: n
${t1}$ :: mean${reduced_shape('x', rank, 'dim')}$
if (.not.optval(mask, .true.)) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
res = 0._${k1}$
select case(dim)
#:for fi in range(1, rank+1)
case(${fi}$)
n = size(x, dim)
mean = sum(x, dim) / n
do i = 1, size(x, dim)
#:if t1[0] == 'r'
res = res + (x${select_subarray(rank, [(fi, 'i')])}$ - mean)**2
#:else
res = res + abs(x${select_subarray(rank, [(fi, 'i')])}$ - mean)**2
#:endif
end do
#:endfor
case default
call error_stop("ERROR (var): wrong dimension")
end select
res = res / (n - merge(1, 0, optval(corrected, .true.)))
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("var",rank, t1, k1, 'dp')
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in), optional :: mask
logical, intent(in), optional :: corrected
real(dp) :: res${reduced_shape('x', rank, 'dim')}$
integer :: i
real(dp) :: n
real(dp) :: mean${reduced_shape('x', rank, 'dim')}$
if (.not.optval(mask, .true.)) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
res = 0._dp
select case(dim)
#:for fi in range(1, rank+1)
case(${fi}$)
n = size(x, dim)
mean = sum(real(x, dp), dim) / n
do i = 1, size(x, dim)
res = res + (real(x${select_subarray(rank, [(fi, 'i')])}$, dp) - mean)**2
end do
#:endfor
case default
call error_stop("ERROR (var): wrong dimension")
end select
res = res / (n - merge(1, 0, optval(corrected, .true.)))
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("var_mask_all",rank, t1, k1)
module function ${RName}$(x, mask, corrected) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in) :: mask${ranksuffix(rank)}$
logical, intent(in), optional :: corrected
real(${k1}$) :: res
real(${k1}$) :: n
${t1}$ :: mean
n = real(count(mask, kind = int64), ${k1}$)
mean = sum(x, mask) / n
#:if t1[0] == 'r'
res = sum((x - mean)**2, mask) / (n -&
#:else
res = sum(abs(x - mean)**2, mask) / (n -&
#:endif
merge(1, 0, (optval(corrected, .true.) .and. n > 0)))
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("var_mask_all",rank, t1, k1, 'dp')
module function ${RName}$(x, mask, corrected) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in) :: mask${ranksuffix(rank)}$
logical, intent(in), optional :: corrected
real(dp) :: res
real(dp) :: n, mean
n = real(count(mask, kind = int64), dp)
mean = sum(real(x, dp), mask) / n
res = sum((real(x, dp) - mean)**2, mask) / (n -&
merge(1, 0, (optval(corrected, .true.) .and. n > 0)))
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("var_mask",rank, t1, k1)
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in) :: mask${ranksuffix(rank)}$
logical, intent(in), optional :: corrected
real(${k1}$) :: res${reduced_shape('x', rank, 'dim')}$
integer :: i
real(${k1}$) :: n${reduced_shape('x', rank, 'dim')}$
${t1}$ :: mean${reduced_shape('x', rank, 'dim')}$
res = 0._${k1}$
select case(dim)
#:for fi in range(1, rank+1)
case(${fi}$)
n = count(mask, dim)
mean = sum(x, dim, mask) / n
do i = 1, size(x, dim)
#:if t1[0] == 'r'
res = res + merge( (x${select_subarray(rank, [(fi, 'i')])}$ - mean)**2,&
#:else
res = res + merge( abs(x${select_subarray(rank, [(fi, 'i')])}$ - mean)**2,&
#:endif
0._${k1}$,&
mask${select_subarray(rank, [(fi, 'i')])}$)
end do
#:endfor
case default
call error_stop("ERROR (var): wrong dimension")
end select
res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("var_mask",rank, t1, k1, 'dp')
module function ${RName}$(x, dim, mask, corrected) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in) :: mask${ranksuffix(rank)}$
logical, intent(in), optional :: corrected
real(dp) :: res${reduced_shape('x', rank, 'dim')}$
integer :: i
real(dp) :: n${reduced_shape('x', rank, 'dim')}$
real(dp) :: mean${reduced_shape('x', rank, 'dim')}$
res = 0._dp
select case(dim)
#:for fi in range(1, rank+1)
case(${fi}$)
n = count(mask, dim)
mean = sum(real(x, dp), dim, mask) / n
do i = 1, size(x, dim)
res = res + merge((real(x${select_subarray(rank, [(fi, 'i')])}$, dp) - mean)**2,&
0._dp, mask${select_subarray(rank, [(fi, 'i')])}$)
end do
#:endfor
case default
call error_stop("ERROR (var): wrong dimension")
end select
res = res / (n - merge(1, 0, (optval(corrected, .true.) .and. n > 0)))
end function ${RName}$
#:endfor
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_distribution_uniform.fypp 0000664 0001750 0001750 00000036771 15135654166 030066 0 ustar alastair alastair #:include "common.fypp"
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
#:set ALL_KINDS_TYPES = INT_KINDS_TYPES + RC_KINDS_TYPES
module stdlib_stats_distribution_uniform
use stdlib_kinds, only : sp, dp, xdp, qp, int8, int16, int32, int64
use stdlib_error, only : error_stop
use stdlib_random, only : dist_rand
implicit none
private
real(dp), parameter :: MESENNE_NUMBER = 1.0_dp / (2.0_dp ** 53 - 1.0_dp)
integer(int64), parameter :: INT_ONE = 1_int64
public :: rvs_uniform
public :: pdf_uniform
public :: cdf_uniform
public :: shuffle
interface rvs_uniform
!! version: experimental
!!
!! Get uniformly distributed random variate for integer, real and complex
!! variables.
!! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html#
!! rvs_uniform-uniform-distribution-random-variates))
module procedure rvs_unif_0_rsp ! 0 dummy variable
#:for k1, t1 in ALL_KINDS_TYPES
module procedure rvs_unif_1_${t1[0]}$${k1}$ ! 1 dummy variable
#:endfor
#:for k1, t1 in ALL_KINDS_TYPES
module procedure rvs_unif_${t1[0]}$${k1}$ ! 2 dummy variables
#:endfor
#:for k1, t1 in ALL_KINDS_TYPES
module procedure rvs_unif_array_${t1[0]}$${k1}$ ! 3 dummy variables
#:endfor
end interface rvs_uniform
interface pdf_uniform
!! version: experimental
!!
!! Get uniform distribution probability density (pdf) for integer, real and
!! complex variables.
!! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html#
!! pdf_uniform-uniform-probability-density-function))
#:for k1, t1 in ALL_KINDS_TYPES
module procedure pdf_unif_${t1[0]}$${k1}$
#:endfor
end interface pdf_uniform
interface cdf_uniform
!! version: experimental
!!
!! Get uniform distribution cumulative distribution function (cdf) for integer,
!! real and complex variables.
!! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html#
!! cdf_uniform-uniform-cumulative-distribution-function))
!!
#:for k1, t1 in ALL_KINDS_TYPES
module procedure cdf_unif_${t1[0]}$${k1}$
#:endfor
end interface cdf_uniform
interface shuffle
!! version: experimental
!!
!! Fisher-Yates shuffle algorithm for a rank one array of integer, real and
!! complex variables.
!! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html#
!! shuffle-using-fisher-yates-algorithm-to-generate-a-random-permutation-of-a-list))
!!
#:for k1, t1 in ALL_KINDS_TYPES
module procedure shuffle_${t1[0]}$${k1}$
#:endfor
end interface shuffle
contains
#:for k1, t1 in INT_KINDS_TYPES
impure elemental function rvs_unif_1_${t1[0]}$${k1}$(scale) result(res)
!
! Uniformly distributed integer in [0, scale]
! Bitmask with rejection
! https://www.pcg-random.org/posts/bounded-rands.html
!
! Fortran 90 translated from c by Jim-215-fisher
!
${t1}$, intent(in) :: scale
${t1}$ :: res, u, mask
integer :: zeros, bits_left, bits
if(scale <= 0_${k1}$) call error_stop("Error(rvs_unif_1): Uniform" &
//" distribution scale parameter must be positive")
zeros = leadz(scale)
bits = bit_size(scale) - zeros
mask = shiftr(not(0_${k1}$), zeros)
L1 : do
u = dist_rand(scale)
res = iand(u, mask)
if(res <= scale) exit L1
bits_left = zeros
L2 : do
if(bits_left < bits) exit L2
u = shiftr(u, bits)
res = iand(u, mask)
if(res <= scale) exit L1
bits_left = bits_left - bits
end do L2
end do L1
end function rvs_unif_1_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
impure elemental function rvs_unif_${t1[0]}$${k1}$(loc, scale) result(res)
!
! Uniformly distributed integer in [loc, loc + scale]
!
${t1}$, intent(in) :: loc, scale
${t1}$ :: res
if(scale <= 0_${k1}$) call error_stop("Error(rvs_unif): Uniform" &
//" distribution scale parameter must be positive")
res = loc + rvs_unif_1_${t1[0]}$${k1}$(scale)
end function rvs_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure elemental function rvs_unif_0_${t1[0]}$${k1}$( ) result(res)
!
! Uniformly distributed float in [0,1]
! Based on the paper by Frederic Goualard, "Generating Random Floating-
! Point Numbers By Dividing Integers: a Case Study", Proceedings of
! ICCS 2020, June 2020, Amsterdam, Netherlands
!
${t1}$ :: res
integer(int64) :: tmp
tmp = shiftr(dist_rand(INT_ONE), 11) ! Get random from [0,2^53-1]
res = real(tmp * MESENNE_NUMBER, kind = ${k1}$) ! convert to [0,1]
end function rvs_unif_0_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure elemental function rvs_unif_1_${t1[0]}$${k1}$(scale) result(res)
!
! Uniformly distributed float in [0, scale]
!
${t1}$, intent(in) :: scale
${t1}$ :: res
if(scale == 0._${k1}$) call error_stop("Error(rvs_unif_1): " &
//"Uniform distribution scale parameter must be non-zero")
res = scale * rvs_unif_0_${t1[0]}$${k1}$( )
end function rvs_unif_1_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
impure elemental function rvs_unif_${t1[0]}$${k1}$(loc, scale) result(res)
!
! Uniformly distributed float in [loc, loc + scale]
!
${t1}$, intent(in) :: loc, scale
${t1}$ :: res
if(scale == 0._${k1}$) call error_stop("Error(rvs_unif): " &
//"Uniform distribution scale parameter must be non-zero")
res = loc + scale * rvs_unif_0_${t1[0]}$${k1}$( )
end function rvs_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure elemental function rvs_unif_1_${t1[0]}$${k1}$(scale) result(res)
!
! Uniformly distributed complex in [(0,0i), (scale, i(scale))]
! The real part and imaginary part are independent of each other, so that
! the joint distribution is on an unit square [(0,0i), (scale,i(scale))]
!
${t1}$, intent(in) :: scale
${t1}$ :: res
real(${k1}$) :: r1, tr, ti
if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(rvs_uni_" &
//"1): Uniform distribution scale parameter must be non-zero")
r1 = rvs_unif_0_r${k1}$( )
if(scale % re == 0.0_${k1}$) then
ti = scale % im * r1
tr = 0.0_${k1}$
else if(scale % im == 0.0_${k1}$) then
tr = scale % re * r1
ti = 0.0_${k1}$
else
tr = scale % re * r1
r1 = rvs_unif_0_r${k1}$( )
ti = scale % im * r1
end if
res = cmplx(tr, ti, kind=${k1}$)
end function rvs_unif_1_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
impure elemental function rvs_unif_${t1[0]}$${k1}$(loc, scale) result(res)
!
! Uniformly distributed complex in [(loc,iloc), (loc + scale, i(loc +
! scale))].
! The real part and imaginary part are independent of each other, so that
! the joint distribution is on an unit square [(loc,iloc), (loc + scale,
! i(loc + scale))]
!
${t1}$, intent(in) :: loc, scale
${t1}$ :: res
real(${k1}$) :: r1, tr, ti
if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(rvs_uni_" &
//"): Uniform distribution scale parameter must be non-zero")
r1 = rvs_unif_0_r${k1}$( )
if(scale % re == 0.0_${k1}$) then
tr = loc % re
ti = loc % im + scale % im * r1
else if(scale % im == 0.0_${k1}$) then
tr = loc % re + scale % re * r1
ti = loc % im
else
tr = loc % re + scale % re * r1
r1 = rvs_unif_0_r${k1}$( )
ti = loc % im + scale % im * r1
end if
res = cmplx(tr, ti, kind=${k1}$)
end function rvs_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
function rvs_unif_array_${t1[0]}$${k1}$(loc, scale, array_size) result(res)
integer, intent(in) :: array_size
${t1}$, intent(in) :: loc, scale
${t1}$ :: res(array_size)
${t1}$ :: u, mask, nn
integer :: i, zeros, bits_left, bits
if(scale == 0_${k1}$) call error_stop("Error(rvs_unif_array): " &
//"Uniform distribution scale parameter must be non-zero")
zeros = leadz(scale)
bits = bit_size(scale) - zeros
mask = shiftr(not(0_${k1}$), zeros)
do i = 1, array_size
L1 : do
u = dist_rand(scale)
nn = iand(u, mask)
if(nn <= scale) exit L1
bits_left = zeros
L2 : do
if(bits_left < bits) exit L2
u = shiftr(u, bits)
nn = iand(u, mask)
if(nn <= scale) exit L1
bits_left = bits_left - bits
end do L2
end do L1
res(i) = loc + nn
end do
end function rvs_unif_array_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
function rvs_unif_array_${t1[0]}$${k1}$(loc, scale, array_size) result(res)
integer, intent(in) :: array_size
${t1}$, intent(in) :: loc, scale
${t1}$ :: res(array_size)
${t1}$ :: t
integer(int64) :: tmp
integer :: i
if(scale == 0._${k1}$) call error_stop("Error(rvs_unif_array):" &
//" Uniform distribution scale parameter must be non-zero")
do i = 1, array_size
tmp = shiftr(dist_rand(INT_ONE), 11)
t = real(tmp * MESENNE_NUMBER, kind = ${k1}$)
res(i) = loc + scale * t
end do
end function rvs_unif_array_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
function rvs_unif_array_${t1[0]}$${k1}$(loc, scale, array_size) result(res)
integer, intent(in) :: array_size
${t1}$, intent(in) :: loc, scale
${t1}$ :: res(array_size)
real(${k1}$) :: r1, tr, ti
integer(int64) :: tmp
integer :: i
if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(rvs_unif" &
//"_array): Uniform distribution scale parameter must be non-zero")
do i = 1, array_size
tmp = shiftr(dist_rand(INT_ONE), 11)
r1 = real(tmp * MESENNE_NUMBER, kind = ${k1}$)
if(scale % re == 0.0_${k1}$) then
tr = loc % re
ti = loc % im + scale % im * r1
else if(scale % im == 0.0_${k1}$) then
tr = loc % re + scale % re * r1
ti = loc % im
else
tr = loc % re + scale % re * r1
tmp = shiftr(dist_rand(INT_ONE), 11)
r1 = real(tmp * MESENNE_NUMBER, kind = ${k1}$)
ti = loc % im + scale % im * r1
end if
res(i) = cmplx(tr, ti, kind=${k1}$)
end do
end function rvs_unif_array_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
elemental function pdf_unif_${t1[0]}$${k1}$(x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
real :: res
if(scale == 0_${k1}$) then
res = 0.0
else if(x < loc .or. x > (loc + scale)) then
res = 0.0
else
res = 1. / (scale + 1_${k1}$)
end if
end function pdf_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function pdf_unif_${t1[0]}$${k1}$(x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
${t1}$ :: res
${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
if(scale == zero) then
res = zero
else if(x < loc .or. x > (loc + scale)) then
res = zero
else
res = one / scale
end if
end function pdf_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function pdf_unif_${t1[0]}$${k1}$(x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
real(${k1}$) :: res, tr, ti
real(${k1}$), parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
tr = loc % re + scale % re; ti = loc % im + scale % im
if(scale == (zero, zero)) then
res = zero
else if((x % re >= loc % re .and. x % re <= tr) .and. &
(x % im >= loc % im .and. x % im <= ti)) then
res = one / (scale % re * scale % im)
else
res = zero
end if
end function pdf_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
elemental function cdf_unif_${t1[0]}$${k1}$(x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
real :: res
if(scale == 0_${k1}$) then
res = 0.0
else if(x < loc) then
res = 0.0
else if(x >= loc .and. x <= (loc + scale)) then
res = real((x - loc + 1_${k1}$)) / real((scale + 1_${k1}$))
else
res = 1.0
end if
end function cdf_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
elemental function cdf_unif_${t1[0]}$${k1}$(x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
${t1}$ :: res
${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
if(scale == zero) then
res = zero
else if(x < loc) then
res = zero
else if(x >= loc .and. x <= (loc + scale)) then
res = (x - loc) / scale
else
res = one
end if
end function cdf_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in CMPLX_KINDS_TYPES
elemental function cdf_unif_${t1[0]}$${k1}$(x, loc, scale) result(res)
${t1}$, intent(in) :: x, loc, scale
real(${k1}$) :: res
real(${k1}$), parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$
logical :: r1, r2, i1, i2
if(scale == (zero, zero)) then
res = zero
return
end if
r1 = x % re < loc % re
r2 = x % re > (loc % re + scale % re)
i1 = x % im < loc % im
i2 = x % im > (loc % im + scale % im)
if(r1 .or. i1) then
res = zero
else if((.not. r1) .and. (.not. r2) .and. i2) then
res = (x % re - loc % re) / scale % re
else if((.not. i1) .and. (.not. i2) .and. r2) then
res = (x % im - loc % im) / scale % im
else if((.not. r1) .and. (.not. r2) .and. (.not. i1) .and. (.not. i2)) &
then
res = ((x % re - loc % re) / scale % re) * ((x % im - loc % im) / &
scale % im)
else if(r2 .and. i2)then
res = one
end if
end function cdf_unif_${t1[0]}$${k1}$
#:endfor
#:for k1, t1 in ALL_KINDS_TYPES
function shuffle_${t1[0]}$${k1}$( list ) result(res)
${t1}$, intent(in) :: list(:)
${t1}$ :: res(size(list))
${t1}$ :: tmp
integer :: n, i, j
n = size(list)
res = list
do i = 1, n - 1
j = rvs_uniform(n - i) + i
tmp = res(i)
res(i) = res(j)
res(j) = tmp
end do
end function shuffle_${t1[0]}$${k1}$
#:endfor
end module stdlib_stats_distribution_uniform
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_moment.fypp 0000664 0001750 0001750 00000006626 15135654166 025103 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set REDRANKS = range(2, MAXRANK + 1)
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_stats) stdlib_stats_moment
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_error, only: error_stop
use stdlib_optval, only: optval
implicit none
contains
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("moment",rank, t1, k1)
module function ${RName}$(x, order, dim, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
integer, intent(in) :: dim
${t1}$, intent(in), optional :: center${reduced_shape('x', rank, 'dim')}$
logical, intent(in), optional :: mask
${t1}$ :: res${reduced_shape('x', rank, 'dim')}$
integer :: i
real(${k1}$) :: n
${t1}$, allocatable :: mean_${ranksuffix(rank-1)}$
if (.not.optval(mask, .true.)) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
n = real(size(x, dim), ${k1}$)
res = 0
select case(dim)
#:for fi in range(1, rank+1)
case(${fi}$)
if (present(center)) then
do i = 1, size(x, ${fi}$)
res = res + (x${select_subarray(rank, [(fi, 'i')])}$ - center)**order
end do
else
allocate(mean_, source = mean(x, ${fi}$))
do i = 1, size(x, ${fi}$)
res = res + (x${select_subarray(rank, [(fi, 'i')])}$ - mean_)**order
end do
deallocate(mean_)
end if
#:endfor
case default
call error_stop("ERROR (moment): wrong dimension")
end select
res = res / n
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("moment",rank, t1, k1, 'dp')
module function ${RName}$(x, order, dim, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
integer, intent(in) :: dim
real(dp),intent(in), optional :: center${reduced_shape('x', rank, 'dim')}$
logical, intent(in), optional :: mask
real(dp) :: res${reduced_shape('x', rank, 'dim')}$
integer :: i
real(dp) :: n
real(dp), allocatable :: mean_${ranksuffix(rank-1)}$
if (.not.optval(mask, .true.)) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
n = real(size(x, dim), dp)
res = 0
select case(dim)
#:for fi in range(1, rank+1)
case(${fi}$)
if (present(center)) then
do i = 1, size(x, ${fi}$)
res = res + (real(x${select_subarray(rank, [(fi, 'i')])}$, dp) -&
center)**order
end do
else
allocate(mean_, source = mean(x, ${fi}$))
do i = 1, size(x, ${fi}$)
res = res + (real(x${select_subarray(rank, [(fi, 'i')])}$, dp) - mean_)**order
end do
deallocate(mean_)
end if
#:endfor
case default
call error_stop("ERROR (moment): wrong dimension")
end select
res = res / n
end function ${RName}$
#:endfor
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_moment_scalar.fypp 0000664 0001750 0001750 00000006772 15135654166 026432 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set REDRANKS = range(2, MAXRANK + 1)
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_stats) stdlib_stats_moment_scalar
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_error, only: error_stop
use stdlib_optval, only: optval
implicit none
contains
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in REDRANKS
#:set RName = rname("moment_scalar",rank, t1, k1)
module function ${RName}$(x, order, dim, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
integer, intent(in) :: dim
${t1}$, intent(in) :: center
logical, intent(in), optional :: mask
${t1}$ :: res${reduced_shape('x', rank, 'dim')}$
if (.not.optval(mask, .true.)) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
if (dim >= 1 .and. dim <= ${rank}$) then
res = sum((x - center)**order, dim) / size(x, dim)
else
call error_stop("ERROR (moment): wrong dimension")
end if
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in REDRANKS
#:set RName = rname("moment_scalar",rank, t1, k1, 'dp')
module function ${RName}$(x, order, dim, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
integer, intent(in) :: dim
real(dp),intent(in) :: center
logical, intent(in), optional :: mask
real(dp) :: res${reduced_shape('x', rank, 'dim')}$
if (.not.optval(mask, .true.)) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
if (dim >= 1 .and. dim <= ${rank}$) then
res = sum( (real(x, dp) - center)**order, dim) / size(x, dim)
else
call error_stop("ERROR (moment): wrong dimension")
end if
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in REDRANKS
#:set RName = rname("moment_mask_scalar",rank, t1, k1)
module function ${RName}$(x, order, dim, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
integer, intent(in) :: dim
${t1}$, intent(in) :: center
logical, intent(in) :: mask${ranksuffix(rank)}$
${t1}$ :: res${reduced_shape('x', rank, 'dim')}$
if (dim >= 1 .and. dim <= ${rank}$) then
res = sum((x - center)**order, dim, mask) / count(mask, dim)
else
call error_stop("ERROR (moment): wrong dimension")
end if
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in REDRANKS
#:set RName = rname("moment_mask_scalar",rank, t1, k1, 'dp')
module function ${RName}$(x, order, dim, center, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: order
integer, intent(in) :: dim
real(dp), intent(in) :: center
logical, intent(in) :: mask${ranksuffix(rank)}$
real(dp) :: res${reduced_shape('x', rank, 'dim')}$
if (dim >= 1 .and. dim <= ${rank}$) then
res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim)
else
call error_stop("ERROR (moment): wrong dimension")
end if
end function ${RName}$
#:endfor
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/stats/stdlib_stats_mean.fypp 0000664 0001750 0001750 00000011626 15135654166 024520 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, MAXRANK + 1)
#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES
submodule (stdlib_stats) stdlib_stats_mean
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use stdlib_error, only: error_stop
use stdlib_optval, only: optval
implicit none
contains
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("mean_all",rank, t1, k1)
module function ${RName}$ (x, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in), optional :: mask
${t1}$ :: res
if (.not.optval(mask, .true.)) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
res = sum(x) / real(size(x, kind = int64), ${k1}$)
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname('mean_all', rank, t1, k1,'dp')
module function ${RName}$(x, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in), optional :: mask
real(dp) :: res
if (.not.optval(mask, .true.)) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
res = sum(real(x, dp)) / real(size(x, kind = int64), dp)
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("mean",rank, t1, k1)
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in), optional :: mask
${t1}$ :: res${reduced_shape('x', rank, 'dim')}$
if (.not.optval(mask, .true.)) then
res = ieee_value(1._${k1}$, ieee_quiet_nan)
return
end if
if (dim >= 1 .and. dim <= ${rank}$) then
res = sum(x, dim) / real(size(x, dim), ${k1}$)
else
call error_stop("ERROR (mean): wrong dimension")
end if
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname("mean",rank, t1, k1,'dp')
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in), optional :: mask
real(dp) :: res${reduced_shape('x', rank, 'dim')}$
if (.not.optval(mask, .true.)) then
res = ieee_value(1._dp, ieee_quiet_nan)
return
end if
if (dim >= 1 .and. dim <= ${rank}$) then
res = sum(real(x, dp), dim) / real(size(x, dim), dp)
else
call error_stop("ERROR (mean): wrong dimension")
end if
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname('mean_mask_all',rank, t1, k1)
module function ${RName}$(x, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in) :: mask${ranksuffix(rank)}$
${t1}$ :: res
res = sum(x, mask) / real(count(mask, kind = int64), ${k1}$)
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname('mean_mask_all',rank, t1, k1, 'dp')
module function ${RName}$(x, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
logical, intent(in) :: mask${ranksuffix(rank)}$
real(dp) :: res
res = sum(real(x, dp), mask) / real(count(mask, kind = int64), dp)
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in RC_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname('mean_mask',rank, t1, k1)
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in) :: mask${ranksuffix(rank)}$
${t1}$ :: res${reduced_shape('x', rank, 'dim')}$
if (dim >= 1 .and. dim <= ${rank}$) then
res = sum(x, dim, mask) / real(count(mask, dim), ${k1}$)
else
call error_stop("ERROR (mean): wrong dimension")
end if
end function ${RName}$
#:endfor
#:endfor
#:for k1, t1 in INT_KINDS_TYPES
#:for rank in RANKS
#:set RName = rname('mean_mask',rank, t1, k1, 'dp')
module function ${RName}$(x, dim, mask) result(res)
${t1}$, intent(in) :: x${ranksuffix(rank)}$
integer, intent(in) :: dim
logical, intent(in) :: mask${ranksuffix(rank)}$
real(dp) :: res${reduced_shape('x', rank, 'dim')}$
if (dim >= 1 .and. dim <= ${rank}$) then
res = sum(real(x, dp), dim, mask) / real(count(mask, dim), dp)
else
call error_stop("ERROR (mean): wrong dimension")
end if
end function ${RName}$
#:endfor
#:endfor
end submodule
fortran-lang-stdlib-0ede301/src/ansi/ 0000775 0001750 0001750 00000000000 15135654166 017707 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/ansi/stdlib_ansi_operator.f90 0000664 0001750 0001750 00000005132 15135654166 024436 0 ustar alastair alastair ! SPDX-Identifier: MIT
!> Implementation of the conversion to enumerator and identifier types to strings
submodule (stdlib_ansi) stdlib_ansi_operator
use stdlib_string_type, only : operator(//)
implicit none
contains
!> Add two escape sequences, attributes in the right value override the left value ones.
pure module function add(lval, rval) result(code)
!> First escape code
type(ansi_code), intent(in) :: lval
!> Second escape code
type(ansi_code), intent(in) :: rval
!> Combined escape code
type(ansi_code) :: code
code%style = merge(rval%style, lval%style, rval%style >= 0)
code%fg = merge(rval%fg, lval%fg, rval%fg >= 0)
code%bg = merge(rval%bg, lval%bg, rval%bg >= 0)
end function add
!> Concatenate an escape code with a string and turn it into an actual escape sequence
pure module function concat_left(lval, code) result(str)
!> String to add the escape code to
character(len=*), intent(in) :: lval
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Concatenated string
character(len=:), allocatable :: str
str = lval // to_string(code)
end function concat_left
!> Concatenate an escape code with a string and turn it into an actual escape sequence
pure module function concat_right(code, rval) result(str)
!> String to add the escape code to
character(len=*), intent(in) :: rval
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Concatenated string
character(len=:), allocatable :: str
str = to_string(code) // rval
end function concat_right
!> Concatenate an escape code with a string and turn it into an actual escape sequence
pure module function concat_left_str(lval, code) result(str)
!> String to add the escape code to
type(string_type), intent(in) :: lval
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Concatenated string
type(string_type) :: str
str = lval // to_string(code)
end function concat_left_str
!> Concatenate an escape code with a string and turn it into an actual escape sequence
pure module function concat_right_str(code, rval) result(str)
!> String to add the escape code to
type(string_type), intent(in) :: rval
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Concatenated string
type(string_type) :: str
str = to_string(code) // rval
end function concat_right_str
end submodule stdlib_ansi_operator
fortran-lang-stdlib-0ede301/src/ansi/stdlib_ansi.f90 0000664 0001750 0001750 00000015517 15135654166 022533 0 ustar alastair alastair ! SPDX-Identifier: MIT
!> Terminal color and style escape sequences
module stdlib_ansi
use stdlib_kinds, only : i1 => int8
use stdlib_string_type, only : string_type
implicit none
private
public :: ansi_code
public :: style_reset, style_bold, style_dim, style_italic, style_underline, &
& style_blink, style_blink_fast, style_reverse, style_hidden, style_strikethrough
public :: fg_color_black, fg_color_red, fg_color_green, fg_color_yellow, fg_color_blue, &
& fg_color_magenta, fg_color_cyan, fg_color_white, fg_color_default
public :: bg_color_black, bg_color_red, bg_color_green, bg_color_yellow, bg_color_blue, &
& bg_color_magenta, bg_color_cyan, bg_color_white, bg_color_default
public :: to_string, operator(+), operator(//)
!> Container for terminal escape code
type :: ansi_code
private
!> Style descriptor
integer(i1) :: style = -1_i1
!> Background color descriptor
integer(i1) :: bg = -1_i1
!> Foreground color descriptor
integer(i1) :: fg = -1_i1
end type ansi_code
!> Identifier for reset style
type(ansi_code), parameter :: style_reset = ansi_code(style=0)
!> Identifier for bold style
type(ansi_code), parameter :: style_bold = ansi_code(style=1)
!> Identifier for dim style
type(ansi_code), parameter :: style_dim = ansi_code(style=2)
!> Identifier for italic style
type(ansi_code), parameter :: style_italic = ansi_code(style=3)
!> Identifier for underline style
type(ansi_code), parameter :: style_underline = ansi_code(style=4)
!> Identifier for blink style
type(ansi_code), parameter :: style_blink = ansi_code(style=5)
!> Identifier for (fast) blink style
type(ansi_code), parameter :: style_blink_fast = ansi_code(style=6)
!> Identifier for reverse style
type(ansi_code), parameter :: style_reverse = ansi_code(style=7)
!> Identifier for hidden style
type(ansi_code), parameter :: style_hidden = ansi_code(style=8)
!> Identifier for strikethrough style
type(ansi_code), parameter :: style_strikethrough = ansi_code(style=9)
!> Identifier for black foreground color
type(ansi_code), parameter :: fg_color_black = ansi_code(fg=0)
!> Identifier for red foreground color
type(ansi_code), parameter :: fg_color_red = ansi_code(fg=1)
!> Identifier for green foreground color
type(ansi_code), parameter :: fg_color_green = ansi_code(fg=2)
!> Identifier for yellow foreground color
type(ansi_code), parameter :: fg_color_yellow = ansi_code(fg=3)
!> Identifier for blue foreground color
type(ansi_code), parameter :: fg_color_blue = ansi_code(fg=4)
!> Identifier for magenta foreground color
type(ansi_code), parameter :: fg_color_magenta = ansi_code(fg=5)
!> Identifier for cyan foreground color
type(ansi_code), parameter :: fg_color_cyan = ansi_code(fg=6)
!> Identifier for white foreground color
type(ansi_code), parameter :: fg_color_white = ansi_code(fg=7)
!> Identifier for the default foreground color
type(ansi_code), parameter :: fg_color_default = ansi_code(fg=9)
!> Identifier for black background color
type(ansi_code), parameter :: bg_color_black = ansi_code(bg=0)
!> Identifier for red background color
type(ansi_code), parameter :: bg_color_red = ansi_code(bg=1)
!> Identifier for green background color
type(ansi_code), parameter :: bg_color_green = ansi_code(bg=2)
!> Identifier for yellow background color
type(ansi_code), parameter :: bg_color_yellow = ansi_code(bg=3)
!> Identifier for blue background color
type(ansi_code), parameter :: bg_color_blue = ansi_code(bg=4)
!> Identifier for magenta background color
type(ansi_code), parameter :: bg_color_magenta = ansi_code(bg=5)
!> Identifier for cyan background color
type(ansi_code), parameter :: bg_color_cyan = ansi_code(bg=6)
!> Identifier for white background color
type(ansi_code), parameter :: bg_color_white = ansi_code(bg=7)
!> Identifier for the default background color
type(ansi_code), parameter :: bg_color_default = ansi_code(bg=9)
interface to_string
!> Transform a color code into an actual ANSI escape sequence
pure module function to_string_ansi_code(code) result(str)
!> Color code to be used
type(ansi_code), intent(in) :: code
!> ANSI escape sequence representing the color code
character(len=:), allocatable :: str
end function to_string_ansi_code
end interface to_string
interface operator(+)
!> Add two escape sequences, attributes in the right value override the left value ones.
pure module function add(lval, rval) result(code)
!> First escape code
type(ansi_code), intent(in) :: lval
!> Second escape code
type(ansi_code), intent(in) :: rval
!> Combined escape code
type(ansi_code) :: code
end function add
end interface operator(+)
interface operator(//)
!> Concatenate an escape code with a string and turn it into an actual escape sequence
pure module function concat_left(lval, code) result(str)
!> String to add the escape code to
character(len=*), intent(in) :: lval
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Concatenated string
character(len=:), allocatable :: str
end function concat_left
!> Concatenate an escape code with a string and turn it into an actual escape sequence
pure module function concat_right(code, rval) result(str)
!> String to add the escape code to
character(len=*), intent(in) :: rval
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Concatenated string
character(len=:), allocatable :: str
end function concat_right
!> Concatenate an escape code with a string and turn it into an actual escape sequence
pure module function concat_left_str(lval, code) result(str)
!> String to add the escape code to
type(string_type), intent(in) :: lval
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Concatenated string
type(string_type) :: str
end function concat_left_str
!> Concatenate an escape code with a string and turn it into an actual escape sequence
pure module function concat_right_str(code, rval) result(str)
!> String to add the escape code to
type(string_type), intent(in) :: rval
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Concatenated string
type(string_type) :: str
end function concat_right_str
end interface operator(//)
end module stdlib_ansi
fortran-lang-stdlib-0ede301/src/ansi/CMakeLists.txt 0000664 0001750 0001750 00000000457 15135654166 022455 0 ustar alastair alastair set(ansi_f90Files
stdlib_ansi.f90
stdlib_ansi_operator.f90
stdlib_ansi_to_string.f90
)
set(ansi_fppFiles
)
configure_stdlib_target(${PROJECT_NAME}_ansi ansi_f90Files ansi_fppFiles "")
target_link_libraries(${PROJECT_NAME}_ansi PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_strings)
fortran-lang-stdlib-0ede301/src/ansi/stdlib_ansi_to_string.f90 0000664 0001750 0001750 00000002666 15135654166 024624 0 ustar alastair alastair ! SPDX-Identifier: MIT
!> Implementation of the conversion to enumerator and identifier types to strings
submodule (stdlib_ansi) stdlib_ansi_to_string
implicit none
character, parameter :: esc = achar(27), chars(0:9) = &
["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]
contains
!> Transform a color code into an actual ANSI escape sequence
pure module function to_string_ansi_code(code) result(str)
!> Color code to be used
type(ansi_code), intent(in) :: code
!> ANSI escape sequence representing the color code
character(len=:), allocatable :: str
if (anycolor(code)) then
str = esc // "[0" ! Always reset the style
if (code%style > 0 .and. code%style < 10) str = str // ";" // chars(code%style)
if (code%fg >= 0 .and. code%fg < 10) str = str // ";3" // chars(code%fg)
if (code%bg >= 0 .and. code%bg < 10) str = str // ";4" // chars(code%bg)
str = str // "m"
else
str = ""
end if
end function to_string_ansi_code
!> Check whether the code describes any color / style or is just a stub
pure function anycolor(code)
!> Escape sequence
type(ansi_code), intent(in) :: code
!> Any color / style is active
logical :: anycolor
anycolor = code%fg >= 0 .or. code%bg >= 0 .or. code%style >= 0
end function anycolor
end submodule stdlib_ansi_to_string
fortran-lang-stdlib-0ede301/src/quadrature/ 0000775 0001750 0001750 00000000000 15135654166 021132 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/quadrature/stdlib_quadrature_gauss.f90 0000664 0001750 0001750 00000007723 15135654166 026403 0 ustar alastair alastair submodule (stdlib_quadrature) stdlib_quadrature_gauss
use stdlib_specialfunctions, only: legendre, dlegendre
implicit none
real(dp), parameter :: pi = acos(-1._dp)
real(dp), parameter :: tolerance = 4._dp * epsilon(1._dp)
integer, parameter :: newton_iters = 100
contains
pure module subroutine gauss_legendre_fp64 (x, w, interval)
real(dp), intent(out) :: x(:), w(:)
real(dp), intent(in), optional :: interval(2)
associate (n => size(x)-1 )
select case (n)
case (0)
x = 0
w = 2
case (1)
x(1) = -sqrt(1._dp/3._dp)
x(2) = -x(1)
w = 1
case default
block
integer :: i,j
real(dp) :: leg, dleg, delta
do i = 0, (n+1)/2 - 1
! use Gauss-Chebyshev points as an initial guess
x(i+1) = -cos((2*i+1)/(2._dp*n+2._dp) * pi)
do j = 1, newton_iters
leg = legendre(n+1,x(i+1))
dleg = dlegendre(n+1,x(i+1))
delta = -leg/dleg
x(i+1) = x(i+1) + delta
if ( abs(delta) <= tolerance * abs(x(i+1)) ) exit
end do
x(n-i+1) = -x(i+1)
dleg = dlegendre(n+1,x(i+1))
w(i+1) = 2._dp/((1-x(i+1)**2)*dleg**2)
w(n-i+1) = w(i+1)
end do
if (mod(n,2) == 0) then
x(n/2+1) = 0
dleg = dlegendre(n+1, 0.0_dp)
w(n/2+1) = 2._dp/(dleg**2)
end if
end block
end select
end associate
if (present(interval)) then
associate ( a => interval(1) , b => interval(2) )
x = 0.5_dp*(b-a)*x+0.5_dp*(b+a)
w = 0.5_dp*(b-a)*w
end associate
end if
end subroutine
pure module subroutine gauss_legendre_lobatto_fp64 (x, w, interval)
real(dp), intent(out) :: x(:), w(:)
real(dp), intent(in), optional :: interval(2)
associate (n => size(x)-1)
select case (n)
case (1)
x(1) = -1
x(2) = 1
w = 1
case default
block
integer :: i,j
real(dp) :: leg, dleg, delta
x(1) = -1._dp
x(n+1) = 1._dp
w(1) = 2._dp/(n*(n+1._dp))
w(n+1) = 2._dp/(n*(n+1._dp))
do i = 1, (n+1)/2 - 1
! initial guess from an approximate form given by SV Parter (1999)
x(i+1) = -cos( (i+0.25_dp)*pi/n - 3/(8*n*pi*(i+0.25_dp)))
do j = 1, newton_iters
leg = legendre(n+1,x(i+1)) - legendre(n-1,x(i+1))
dleg = dlegendre(n+1,x(i+1)) - dlegendre(n-1,x(i+1))
delta = -leg/dleg
x(i+1) = x(i+1) + delta
if ( abs(delta) <= tolerance * abs(x(i+1)) ) exit
end do
x(n-i+1) = -x(i+1)
leg = legendre(n, x(i+1))
w(i+1) = 2._dp/(n*(n+1._dp)*leg**2)
w(n-i+1) = w(i+1)
end do
if (mod(n,2) == 0) then
x(n/2+1) = 0
leg = legendre(n, 0.0_dp)
w(n/2+1) = 2._dp/(n*(n+1._dp)*leg**2)
end if
end block
end select
end associate
if (present(interval)) then
associate ( a => interval(1) , b => interval(2) )
x = 0.5_dp*(b-a)*x+0.5_dp*(b+a)
x(1) = interval(1)
x(size(x)) = interval(2)
w = 0.5_dp*(b-a)*w
end associate
end if
end subroutine
end submodule
fortran-lang-stdlib-0ede301/src/quadrature/CMakeLists.txt 0000664 0001750 0001750 00000000672 15135654166 023677 0 ustar alastair alastair set(quadrature_fppFiles
stdlib_quadrature.fypp
stdlib_quadrature_trapz.fypp
stdlib_quadrature_simps.fypp
)
set(quadrature_cppFiles
)
set(quadrature_f90Files
stdlib_quadrature_gauss.f90
)
configure_stdlib_target(${PROJECT_NAME}_quadrature quadrature_f90Files quadrature_fppFiles quadrature_cppFiles)
target_link_libraries(${PROJECT_NAME}_quadrature PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_specialfunctions)
fortran-lang-stdlib-0ede301/src/quadrature/stdlib_quadrature_trapz.fypp 0000664 0001750 0001750 00000004434 15135654166 026775 0 ustar alastair alastair #:include "common.fypp"
submodule (stdlib_quadrature) stdlib_quadrature_trapz
use stdlib_error, only: check
implicit none
contains
#:for KIND in REAL_KINDS
pure module function trapz_dx_${KIND}$(y, dx) result(integral)
real(${KIND}$), dimension(:), intent(in) :: y
real(${KIND}$), intent(in) :: dx
real(${KIND}$) :: integral
integer :: n
n = size(y)
select case (n)
case (0:1)
integral = 0.0_${KIND}$
case (2)
integral = 0.5_${KIND}$*dx*(y(1) + y(2))
case default
integral = dx*(sum(y(2:n-1)) + 0.5_${KIND}$*(y(1) + y(n)))
end select
end function trapz_dx_${KIND}$
#:endfor
#:for KIND in REAL_KINDS
module function trapz_x_${KIND}$(y, x) result(integral)
real(${KIND}$), dimension(:), intent(in) :: y
real(${KIND}$), dimension(:), intent(in) :: x
real(${KIND}$) :: integral
integer :: i
integer :: n
n = size(y)
call check(size(x) == n, "trapz: Arguments `x` and `y` must be the same size.")
select case (n)
case (0:1)
integral = 0.0_${KIND}$
case (2)
integral = 0.5_${KIND}$*(x(2) - x(1))*(y(1) + y(2))
case default
integral = 0.0_${KIND}$
do i = 2, n
integral = integral + (x(i) - x(i-1))*(y(i) + y(i-1))
end do
integral = 0.5_${KIND}$*integral
end select
end function trapz_x_${KIND}$
#:endfor
#:for KIND in REAL_KINDS
pure module function trapz_weights_${KIND}$(x) result(w)
real(${KIND}$), dimension(:), intent(in) :: x
real(${KIND}$), dimension(size(x)) :: w
integer :: i
integer :: n
n = size(x)
select case (n)
case (0)
! no action needed
case (1)
w(1) = 0.0_${KIND}$
case (2)
w = 0.5_${KIND}$*(x(2) - x(1))
case default
w(1) = 0.5_${KIND}$*(x(2) - x(1))
w(n) = 0.5_${KIND}$*(x(n) - x(n-1))
do i = 2, size(x)-1
w(i) = 0.5_${KIND}$*(x(i+1) - x(i-1))
end do
end select
end function trapz_weights_${KIND}$
#:endfor
end submodule stdlib_quadrature_trapz
fortran-lang-stdlib-0ede301/src/quadrature/stdlib_quadrature.fypp 0000664 0001750 0001750 00000010705 15135654166 025553 0 ustar alastair alastair #:include "common.fypp"
module stdlib_quadrature
!! ([Specification](../page/specs/stdlib_quadrature.html#description))
use stdlib_kinds, only: sp, dp, xdp, qp
implicit none
private
! array integration
public :: trapz
public :: trapz_weights
public :: simps
public :: simps_weights
public :: gauss_legendre
public :: gauss_legendre_lobatto
interface trapz
!! version: experimental
!!
!! Integrates sampled values using trapezoidal rule
!! ([Specification](../page/specs/stdlib_quadrature.html#description))
#:for k1, t1 in REAL_KINDS_TYPES
pure module function trapz_dx_${k1}$(y, dx) result(integral)
${t1}$, dimension(:), intent(in) :: y
${t1}$, intent(in) :: dx
${t1}$ :: integral
end function trapz_dx_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
module function trapz_x_${k1}$(y, x) result(integral)
${t1}$, dimension(:), intent(in) :: y
${t1}$, dimension(:), intent(in) :: x
${t1}$ :: integral
end function trapz_x_${k1}$
#:endfor
end interface trapz
interface trapz_weights
!! version: experimental
!!
!! Integrates sampled values using trapezoidal rule weights for given abscissas
!! ([Specification](../page/specs/stdlib_quadrature.html#description_1))
#:for k1, t1 in REAL_KINDS_TYPES
pure module function trapz_weights_${k1}$(x) result(w)
${t1}$, dimension(:), intent(in) :: x
${t1}$, dimension(size(x)) :: w
end function trapz_weights_${k1}$
#:endfor
end interface trapz_weights
interface simps
!! version: experimental
!!
!! Integrates sampled values using Simpson's rule
!! ([Specification](../page/specs/stdlib_quadrature.html#description_3))
! "recursive" is an implementation detail
#:for k1, t1 in REAL_KINDS_TYPES
pure recursive module function simps_dx_${k1}$(y, dx, even) result(integral)
${t1}$, dimension(:), intent(in) :: y
${t1}$, intent(in) :: dx
integer, intent(in), optional :: even
${t1}$ :: integral
end function simps_dx_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
recursive module function simps_x_${k1}$(y, x, even) result(integral)
${t1}$, dimension(:), intent(in) :: y
${t1}$, dimension(:), intent(in) :: x
integer, intent(in), optional :: even
${t1}$ :: integral
end function simps_x_${k1}$
#:endfor
end interface simps
interface simps_weights
!! version: experimental
!!
!! Integrates sampled values using trapezoidal rule weights for given abscissas
!! ([Specification](../page/specs/stdlib_quadrature.html#description_3))
#:for k1, t1 in REAL_KINDS_TYPES
pure recursive module function simps_weights_${k1}$(x, even) result(w)
${t1}$, dimension(:), intent(in) :: x
integer, intent(in), optional :: even
${t1}$, dimension(size(x)) :: w
end function simps_weights_${k1}$
#:endfor
end interface simps_weights
interface gauss_legendre
!! version: experimental
!!
!! Computes Gauss-Legendre quadrature nodes and weights.
pure module subroutine gauss_legendre_fp64 (x, w, interval)
real(dp), intent(out) :: x(:), w(:)
real(dp), intent(in), optional :: interval(2)
end subroutine
end interface gauss_legendre
interface gauss_legendre_lobatto
!! version: experimental
!!
!! Computes Gauss-Legendre-Lobatto quadrature nodes and weights.
pure module subroutine gauss_legendre_lobatto_fp64 (x, w, interval)
real(dp), intent(out) :: x(:), w(:)
real(dp), intent(in), optional :: interval(2)
end subroutine
end interface gauss_legendre_lobatto
! Interface for a simple f(x)-style integrand function.
! Could become fancier as we learn about the performance
! ramifications of different ways to do callbacks.
abstract interface
#:for k1, t1 in REAL_KINDS_TYPES
pure function integrand_${k1}$(x) result(f)
import :: ${k1}$
${t1}$, intent(in) :: x
${t1}$ :: f
end function integrand_${k1}$
#:endfor
end interface
end module stdlib_quadrature
fortran-lang-stdlib-0ede301/src/quadrature/stdlib_quadrature_simps.fypp 0000664 0001750 0001750 00000022533 15135654166 026770 0 ustar alastair alastair #:include "common.fypp"
submodule (stdlib_quadrature) stdlib_quadrature_simps
use stdlib_error, only: check
implicit none
! internal use only
interface simps38
#:for k1, t1 in REAL_KINDS_TYPES
module procedure simps38_dx_${k1}$
module procedure simps38_x_${k1}$
#:endfor
end interface simps38
! internal use only
interface simps38_weights
#:for k1, t1 in REAL_KINDS_TYPES
module procedure simps38_weights_${k1}$
#:endfor
end interface simps38_weights
contains
#:for k1, t1 in REAL_KINDS_TYPES
pure recursive module function simps_dx_${k1}$(y, dx, even) result(integral)
${t1}$, dimension(:), intent(in) :: y
${t1}$, intent(in) :: dx
integer, intent(in), optional :: even
${t1}$ :: integral
integer :: n
n = size(y)
select case (n)
case (0:1)
integral = 0.0_${k1}$
case (2)
integral = 0.5_${k1}$*dx*(y(1) + y(2))
case (3)
integral = dx/3.0_${k1}$*(y(1) + 4*y(2) + y(3))
case (4)
integral = simps38(y, dx)
! case (5) not needed; handled by default
case (6) ! needs special handling because of averaged 3/8's rule case
if (present(even)) then
if (even < 0) then
! 3/8 rule on left
integral = simps38(y(1:4), dx) + simps(y(4:6), dx)
return
else if (even > 0) then
! 3/8 rule on right
integral = simps(y(1:3), dx) + simps38(y(3:6), dx)
return
else
! fall through
end if
end if
! either `even` not present or is zero
! equivalent to averaging left and right
integral = dx/48.0_${k1}$ * (17*(y(1) + y(6)) + 59*(y(2) + y(5)) + 44*(y(3) + y(4)))
case default
if (mod(n, 2) == 1) then
integral = dx/3.0_${k1}$*(y(1) + 4*sum(y(2:n-1:2)) + 2*sum(y(3:n-2:2)) + y(n))
else
if (present(even)) then
if (even < 0) then
! 3/8th rule on left
integral = simps38(y(1:4), dx) + simps(y(4:n), dx)
return
else if (even > 0) then
! 3/8 rule on right
integral = simps(y(1:n-3), dx) + simps38(y(n-3:n), dx)
return
else
! fall through
end if
end if
! either `even` not present or is zero
! equivalent to averaging left and right
integral = dx/48.0_${k1}$ * (17*(y(1) + y(n)) + 59*(y(2) + y(n-1)) &
+ 43*(y(3) + y(n-2)) + 49*(y(4) + y(n-3)) + 48*sum(y(5:n-4)))
end if
end select
end function simps_dx_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
recursive module function simps_x_${k1}$(y, x, even) result(integral)
${t1}$, dimension(:), intent(in) :: y
${t1}$, dimension(:), intent(in) :: x
integer, intent(in), optional :: even
${t1}$ :: integral
integer :: i
integer :: n
${t1}$ :: h1, h2
${t1}$ :: a, b, c
n = size(y)
call check(size(x) == n, "simps: Arguments `x` and `y` must be the same size.")
select case (n)
case (0:1)
integral = 0.0_${k1}$
case (2)
integral = 0.5_${k1}$*(x(2) - x(1))*(y(1) + y(2))
case (3)
h1 = x(2) - x(1)
h2 = x(3) - x(2)
a = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
b = (h1+h2)**3/(6*h1*h2)
c = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
integral = a*y(1) + b*y(2) + c*y(3)
case (4)
integral = simps38(y, x)
! case (6) unneeded; handled by default
case default
if (mod(n, 2) == 1) then
integral = 0.0_${k1}$
do i = 1, n-2, 2
h1 = x(i+1) - x(i)
h2 = x(i+2) - x(i+1)
a = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
b = (h1+h2)**3/(6*h1*h2)
c = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
integral = integral + a*y(i) + b*y(i+1) + c*y(i+2)
end do
else
if (present(even)) then
if (even < 0) then
! 3/8 rule on left
integral = simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n))
return
else if (even > 0) then
! 3/8 rule on right
integral = simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n))
return
else
! fall through
end if
end if
! either `even` not present or is zero
integral = 0.5_${k1}$ * ( simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) &
+ simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) )
end if
end select
end function simps_x_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
pure recursive module function simps_weights_${k1}$(x, even) result(w)
${t1}$, dimension(:), intent(in) :: x
integer, intent(in), optional :: even
${t1}$, dimension(size(x)) :: w
integer :: i, n
${t1}$ :: h1, h2
n = size(x)
select case (n)
case (0)
! no action needed
case (1)
w(1) = 0.0_${k1}$
case (2)
w = 0.5_${k1}$*(x(2) - x(1))
case (3)
h1 = x(2) - x(1)
h2 = x(3) - x(2)
w(1) = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
w(2) = (h1+h2)**3/(6*h1*h2)
w(3) = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
case (4)
w = simps38_weights(x)
case default
if (mod(n, 2) == 1) then
w = 0.0_${k1}$
do i = 1, n-2, 2
h1 = x(i+1) - x(i)
h2 = x(i+2) - x(i+1)
w(i) = w(i) + (2*h1**2 + h1*h2 - h2**2)/(6*h1)
w(i+1) = w(i+1) + (h1+h2)**3/(6*h1*h2)
w(i+2) = w(i+2) + (2*h2**2 + h1*h2 - h1**2)/(6*h2)
end do
else
if (present(even)) then
if (even < 0) then
! 3/8 rule on left
w = 0.0_${k1}$
w(1:4) = simps38_weights(x(1:4))
w(4:n) = w(4:n) + simps_weights(x(4:n)) ! position 4 needs both rules
return
else if (even > 0) then
! 3/8 rule on right
w = 0.0_${k1}$
w(1:n-3) = simps_weights(x(1:n-3))
w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) ! position n-3 needs both rules
return
else
! fall through
end if
end if
! either `even` not present or is zero
w = 0.0_${k1}$
! 3/8 rule on left
w(1:4) = simps38_weights(x(1:4))
w(4:n) = w(4:n) + simps_weights(x(4:n))
! 3/8 rule on right
w(1:n-3) = w(1:n-3) + simps_weights(x(1:n-3))
w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n))
! average
w = 0.5_${k1}$ * w
end if
end select
end function simps_weights_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
pure function simps38_dx_${k1}$(y, dx) result (integral)
${t1}$, dimension(4), intent(in) :: y
${t1}$, intent(in) :: dx
${t1}$ :: integral
integral = 3.0_${k1}$*dx/8.0_${k1}$ * (y(1) + y(4) + 3*(y(2) + y(3)))
end function simps38_dx_${k1}$
#:endfor
#: for k1, t1 in REAL_KINDS_TYPES
pure function simps38_x_${k1}$(y, x) result(integral)
${t1}$, dimension(4), intent(in) :: y
${t1}$, dimension(4), intent(in) :: x
${t1}$ :: integral
${t1}$ :: h1, h2, h3
${t1}$ :: a, b, c, d
h1 = x(2) - x(1)
h2 = x(3) - x(2)
h3 = x(4) - x(3)
a = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2))
b = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3))
c = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2))
d = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3))
integral = a*y(1) + b*y(2) + c*y(3) + d*y(4)
end function simps38_x_${k1}$
#:endfor
#:for k1, t1 in REAL_KINDS_TYPES
pure function simps38_weights_${k1}$(x) result(w)
${t1}$, intent(in) :: x(4)
${t1}$ :: w(size(x))
${t1}$ :: h1, h2, h3
h1 = x(2) - x(1)
h2 = x(3) - x(2)
h3 = x(4) - x(3)
w(1) = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2))
w(2) = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3))
w(3) = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2))
w(4) = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3))
end function simps38_weights_${k1}$
#:endfor
end submodule stdlib_quadrature_simps
fortran-lang-stdlib-0ede301/src/sparse/ 0000775 0001750 0001750 00000000000 15135654166 020252 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/sparse/stdlib_sparse.f90 0000664 0001750 0001750 00000000223 15135654166 023425 0 ustar alastair alastair !! public API
module stdlib_sparse
use stdlib_sparse_kinds
use stdlib_sparse_conversion
use stdlib_sparse_spmv
end module stdlib_sparse fortran-lang-stdlib-0ede301/src/sparse/stdlib_sparse_spmv.fypp 0000664 0001750 0001750 00000060567 15135654166 025073 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, 2+1)
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES
#! define ranks without parentheses
#:def rksfx2(rank)
#{if rank > 0}#${":," + ":," * (rank - 1)}$#{endif}#
#:enddef
!! The `stdlib_sparse_spmv` submodule provides matrix-vector product kernels.
!!
! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose
module stdlib_sparse_spmv
use stdlib_sparse_constants
use stdlib_sparse_kinds
implicit none
private
!! Version experimental
!!
!! Apply the sparse matrix-vector product $$y = \alpha * op(M) * x + \beta * y $$
!! [Specifications](../page/specs/stdlib_sparse.html#spmv)
interface spmv
#:for k1, t1, s1 in (KINDS_TYPES)
#:for rank in RANKS
module procedure :: spmv_coo_${rank}$d_${s1}$
module procedure :: spmv_csr_${rank}$d_${s1}$
module procedure :: spmv_csc_${rank}$d_${s1}$
module procedure :: spmv_ell_${rank}$d_${s1}$
#:endfor
module procedure :: spmv_sellc_${s1}$
#:endfor
end interface
public :: spmv
contains
!! spmv_coo
#:for k1, t1, s1 in (KINDS_TYPES)
#:for rank in RANKS
subroutine spmv_coo_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta,op)
type(COO_${s1}$_type), intent(in) :: matrix
${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$
${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$
${t1}$, intent(in), optional :: alpha
${t1}$, intent(in), optional :: beta
character(1), intent(in), optional :: op
${t1}$ :: alpha_
character(1) :: op_
integer(ilp) :: k, ik, jk
op_ = sparse_op_none; if(present(op)) op_ = op
alpha_ = one_${k1}$
if(present(alpha)) alpha_ = alpha
if(present(beta)) then
vec_y = beta * vec_y
else
vec_y = zero_${s1}$
endif
associate( data => matrix%data, index => matrix%index, storage => matrix%storage, nnz => matrix%nnz )
select case(op_)
case(sparse_op_none)
if(storage == sparse_full) then
do concurrent (k = 1:nnz)
ik = index(1,k)
jk = index(2,k)
vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$jk)
end do
else
do concurrent (k = 1:nnz)
ik = index(1,k)
jk = index(2,k)
vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$jk)
if( ik==jk ) cycle
vec_y(${rksfx2(rank-1)}$jk) = vec_y(${rksfx2(rank-1)}$jk) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$ik)
end do
end if
case(sparse_op_transpose)
if(storage == sparse_full) then
do concurrent (k = 1:nnz)
jk = index(1,k)
ik = index(2,k)
vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$jk)
end do
else
do concurrent (k = 1:nnz)
jk = index(1,k)
ik = index(2,k)
vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$jk)
if( ik==jk ) cycle
vec_y(${rksfx2(rank-1)}$jk) = vec_y(${rksfx2(rank-1)}$jk) + alpha_*data(k) * vec_x(${rksfx2(rank-1)}$ik)
end do
end if
#:if t1.startswith('complex')
case(sparse_op_hermitian)
if(storage == sparse_full) then
do concurrent (k = 1:nnz)
jk = index(1,k)
ik = index(2,k)
vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*conjg(data(k)) * vec_x(${rksfx2(rank-1)}$jk)
end do
else
do concurrent (k = 1:nnz)
jk = index(1,k)
ik = index(2,k)
vec_y(${rksfx2(rank-1)}$ik) = vec_y(${rksfx2(rank-1)}$ik) + alpha_*conjg(data(k)) * vec_x(${rksfx2(rank-1)}$jk)
if( ik==jk ) cycle
vec_y(${rksfx2(rank-1)}$jk) = vec_y(${rksfx2(rank-1)}$jk) + alpha_*conjg(data(k)) * vec_x(${rksfx2(rank-1)}$ik)
end do
end if
#:endif
end select
end associate
end subroutine
#:endfor
#:endfor
!! spmv_csr
#:for k1, t1, s1 in (KINDS_TYPES)
#:for rank in RANKS
subroutine spmv_csr_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta,op)
type(CSR_${s1}$_type), intent(in) :: matrix
${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$
${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$
${t1}$, intent(in), optional :: alpha
${t1}$, intent(in), optional :: beta
character(1), intent(in), optional :: op
${t1}$ :: alpha_
character(1) :: op_
integer(ilp) :: i, j
#:if rank == 1
${t1}$ :: aux, aux2
#:else
${t1}$ :: aux(size(vec_x,dim=1)), aux2(size(vec_x,dim=1))
#:endif
op_ = sparse_op_none; if(present(op)) op_ = op
alpha_ = one_${k1}$
if(present(alpha)) alpha_ = alpha
if(present(beta)) then
vec_y = beta * vec_y
else
vec_y = zero_${s1}$
endif
associate( data => matrix%data, col => matrix%col, rowptr => matrix%rowptr, &
& nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage )
if( storage == sparse_full .and. op_==sparse_op_none ) then
do i = 1, nrows
aux = zero_${k1}$
do j = rowptr(i), rowptr(i+1)-1
aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j))
end do
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux
end do
else if( storage == sparse_full .and. op_==sparse_op_transpose ) then
do i = 1, nrows
aux = alpha_ * vec_x(${rksfx2(rank-1)}$i)
do j = rowptr(i), rowptr(i+1)-1
vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux
end do
end do
else if( storage == sparse_lower .and. op_/=sparse_op_hermitian )then
do i = 1 , nrows
aux = zero_${s1}$
aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i)
do j = rowptr(i), rowptr(i+1)-2
aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j))
vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux2
end do
aux = alpha_ * aux + data(j) * aux2
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + aux
end do
else if( storage == sparse_upper .and. op_/=sparse_op_hermitian )then
do i = 1 , nrows
aux = vec_x(${rksfx2(rank-1)}$i) * data(rowptr(i))
aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i)
do j = rowptr(i)+1, rowptr(i+1)-1
aux = aux + data(j) * vec_x(${rksfx2(rank-1)}$col(j))
vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + data(j) * aux2
end do
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux
end do
#:if t1.startswith('complex')
else if( storage == sparse_full .and. op_==sparse_op_hermitian) then
do i = 1, nrows
aux = alpha_ * vec_x(${rksfx2(rank-1)}$i)
do j = rowptr(i), rowptr(i+1)-1
vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux
end do
end do
else if( storage == sparse_lower .and. op_==sparse_op_hermitian )then
do i = 1 , nrows
aux = zero_${s1}$
aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i)
do j = rowptr(i), rowptr(i+1)-2
aux = aux + conjg(data(j)) * vec_x(${rksfx2(rank-1)}$col(j))
vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux2
end do
aux = alpha_ * aux + conjg(data(j)) * aux2
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + aux
end do
else if( storage == sparse_upper .and. op_==sparse_op_hermitian )then
do i = 1 , nrows
aux = vec_x(${rksfx2(rank-1)}$i) * conjg(data(rowptr(i)))
aux2 = alpha_ * vec_x(${rksfx2(rank-1)}$i)
do j = rowptr(i)+1, rowptr(i+1)-1
aux = aux + conjg(data(j)) * vec_x(${rksfx2(rank-1)}$col(j))
vec_y(${rksfx2(rank-1)}$col(j)) = vec_y(${rksfx2(rank-1)}$col(j)) + conjg(data(j)) * aux2
end do
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * aux
end do
#:endif
end if
end associate
end subroutine
#:endfor
#:endfor
!! spmv_csc
#:for k1, t1, s1 in (KINDS_TYPES)
#:for rank in RANKS
subroutine spmv_csc_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta,op)
type(CSC_${s1}$_type), intent(in) :: matrix
${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$
${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$
${t1}$, intent(in), optional :: alpha
${t1}$, intent(in), optional :: beta
character(1), intent(in), optional :: op
${t1}$ :: alpha_
character(1) :: op_
integer(ilp) :: i, j
#:if rank == 1
${t1}$ :: aux
#:else
${t1}$ :: aux(size(vec_x,dim=1))
#:endif
op_ = sparse_op_none; if(present(op)) op_ = op
alpha_ = one_${k1}$
if(present(alpha)) alpha_ = alpha
if(present(beta)) then
vec_y = beta * vec_y
else
vec_y = zero_${s1}$
endif
associate( data => matrix%data, colptr => matrix%colptr, row => matrix%row, &
& nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage )
if( storage == sparse_full .and. op_==sparse_op_none ) then
do concurrent(j=1:ncols)
aux = alpha_ * vec_x(${rksfx2(rank-1)}$j)
do i = colptr(j), colptr(j+1)-1
vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + data(i) * aux
end do
end do
else if( storage == sparse_full .and. op_==sparse_op_transpose ) then
do concurrent(j=1:ncols)
aux = zero_${k1}$
do i = colptr(j), colptr(j+1)-1
aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$row(i))
end do
vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux
end do
else if( storage == sparse_lower .and. op_/=sparse_op_hermitian )then
do j = 1 , ncols
aux = vec_x(${rksfx2(rank-1)}$j) * data(colptr(j))
do i = colptr(j)+1, colptr(j+1)-1
aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$row(i))
vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + alpha_ * data(i) * vec_x(${rksfx2(rank-1)}$j)
end do
vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux
end do
else if( storage == sparse_upper .and. op_/=sparse_op_hermitian )then
do j = 1 , ncols
aux = zero_${s1}$
do i = colptr(j), colptr(i+1)-2
aux = aux + data(i) * vec_x(${rksfx2(rank-1)}$j)
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * data(i) * vec_x(${rksfx2(rank-1)}$row(i))
end do
aux = aux + data(colptr(j)) * vec_x(${rksfx2(rank-1)}$j)
vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux
end do
#:if t1.startswith('complex')
else if( storage == sparse_full .and. op_==sparse_op_hermitian ) then
do concurrent(j=1:ncols)
aux = zero_${k1}$
do i = colptr(j), colptr(j+1)-1
aux = aux + conjg(data(i)) * vec_x(${rksfx2(rank-1)}$row(i))
end do
vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux
end do
else if( storage == sparse_lower .and. op_==sparse_op_hermitian )then
do j = 1 , ncols
aux = vec_x(${rksfx2(rank-1)}$j) * conjg(data(colptr(j)))
do i = colptr(j)+1, colptr(j+1)-1
aux = aux + conjg(data(i)) * vec_x(${rksfx2(rank-1)}$row(i))
vec_y(${rksfx2(rank-1)}$row(i)) = vec_y(${rksfx2(rank-1)}$row(i)) + alpha_ * conjg(data(i)) * vec_x(${rksfx2(rank-1)}$j)
end do
vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux
end do
else if( storage == sparse_upper .and. op_==sparse_op_hermitian )then
do j = 1 , ncols
aux = zero_${s1}$
do i = colptr(j), colptr(i+1)-2
aux = aux + conjg(data(i)) * vec_x(${rksfx2(rank-1)}$j)
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_ * conjg(data(i)) * vec_x(${rksfx2(rank-1)}$row(i))
end do
aux = aux + conjg(data(colptr(j))) * vec_x(${rksfx2(rank-1)}$j)
vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_ * aux
end do
#:endif
end if
end associate
end subroutine
#:endfor
#:endfor
!! spmv_ell
#:for k1, t1, s1 in (KINDS_TYPES)
#:for rank in RANKS
subroutine spmv_ell_${rank}$d_${s1}$(matrix,vec_x,vec_y,alpha,beta,op)
type(ELL_${s1}$_type), intent(in) :: matrix
${t1}$, intent(in) :: vec_x${ranksuffix(rank)}$
${t1}$, intent(inout) :: vec_y${ranksuffix(rank)}$
${t1}$, intent(in), optional :: alpha
${t1}$, intent(in), optional :: beta
character(1), intent(in), optional :: op
${t1}$ :: alpha_
character(1) :: op_
integer(ilp) :: i, j, k
op_ = sparse_op_none; if(present(op)) op_ = op
alpha_ = one_${k1}$
if(present(alpha)) alpha_ = alpha
if(present(beta)) then
vec_y = beta * vec_y
else
vec_y = zero_${s1}$
endif
associate( data => matrix%data, index => matrix%index, MNZ_P_ROW => matrix%K, &
& nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage )
if( storage == sparse_full .and. op_==sparse_op_none ) then
do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW)
j = index(i,k)
if(j>0) vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$j)
end do
else if( storage == sparse_full .and. op_==sparse_op_transpose ) then
do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW)
j = index(i,k)
if(j>0) vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$i)
end do
else if( storage /= sparse_full .and. op_/=sparse_op_hermitian ) then
do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW)
j = index(i,k)
if(j>0) then
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$j)
if(i==j) cycle
vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*data(i,k) * vec_x(${rksfx2(rank-1)}$i)
end if
end do
#:if t1.startswith('complex')
else if( storage == sparse_full .and. op_==sparse_op_hermitian ) then
do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW)
j = index(i,k)
if(j>0) vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*conjg(data(i,k)) * vec_x(${rksfx2(rank-1)}$i)
end do
else if( storage /= sparse_full .and. op_==sparse_op_hermitian ) then
do concurrent (i = 1:nrows, k = 1:MNZ_P_ROW)
j = index(i,k)
if(j>0) then
vec_y(${rksfx2(rank-1)}$i) = vec_y(${rksfx2(rank-1)}$i) + alpha_*conjg(data(i,k)) * vec_x(${rksfx2(rank-1)}$j)
if(i==j) cycle
vec_y(${rksfx2(rank-1)}$j) = vec_y(${rksfx2(rank-1)}$j) + alpha_*conjg(data(i,k)) * vec_x(${rksfx2(rank-1)}$i)
end if
end do
#:endif
end if
end associate
end subroutine
#:endfor
#:endfor
!! spmv_sellc
#:set CHUNKS = [4,8,16]
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine spmv_sellc_${s1}$(matrix,vec_x,vec_y,alpha,beta,op)
!! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves
type(SELLC_${s1}$_type), intent(in) :: matrix
${t1}$, intent(in) :: vec_x(:)
${t1}$, intent(inout) :: vec_y(:)
${t1}$, intent(in), optional :: alpha
${t1}$, intent(in), optional :: beta
character(1), intent(in), optional :: op
${t1}$ :: alpha_
character(1) :: op_
integer(ilp) :: i, nz, rowidx, num_chunks, rm
op_ = sparse_op_none; if(present(op)) op_ = op
alpha_ = one_${s1}$
if(present(alpha)) alpha_ = alpha
if(present(beta)) then
vec_y = beta * vec_y
else
vec_y = zero_${s1}$
endif
associate( data => matrix%data, ia => matrix%rowptr , ja => matrix%col, cs => matrix%chunk_size, &
& nnz => matrix%nnz, nrows => matrix%nrows, ncols => matrix%ncols, storage => matrix%storage )
if( .not.any( ${CHUNKS}$ == cs ) ) then
print *, "error: sellc chunk size not supported."
return
end if
num_chunks = nrows / cs
rm = nrows - num_chunks * cs
if( storage == sparse_full .and. op_==sparse_op_none ) then
select case(cs)
#:for chunk in CHUNKS
case(${chunk}$)
do i = 1, num_chunks
nz = ia(i+1) - ia(i)
rowidx = (i - 1)*${chunk}$ + 1
call chunk_kernel_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:))
end do
#:endfor
end select
! remainder
if(rm>0)then
i = num_chunks + 1
nz = ia(i+1) - ia(i)
rowidx = (i - 1)*cs + 1
call chunk_kernel_rm(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x,vec_y(rowidx:))
end if
else if( storage == sparse_full .and. op_==sparse_op_transpose ) then
select case(cs)
#:for chunk in CHUNKS
case(${chunk}$)
do i = 1, num_chunks
nz = ia(i+1) - ia(i)
rowidx = (i - 1)*${chunk}$ + 1
call chunk_kernel_trans_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y)
end do
#:endfor
end select
! remainder
if(rm>0)then
i = num_chunks + 1
nz = ia(i+1) - ia(i)
rowidx = (i - 1)*cs + 1
call chunk_kernel_rm_trans(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y)
end if
#:if t1.startswith('complex')
else if( storage == sparse_full .and. op_==sparse_op_hermitian ) then
select case(cs)
#:for chunk in CHUNKS
case(${chunk}$)
do i = 1, num_chunks
nz = ia(i+1) - ia(i)
rowidx = (i - 1)*${chunk}$ + 1
call chunk_kernel_herm_${chunk}$(nz,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y)
end do
#:endfor
end select
! remainder
if(rm>0)then
i = num_chunks + 1
nz = ia(i+1) - ia(i)
rowidx = (i - 1)*cs + 1
call chunk_kernel_rm_herm(nz,cs,rm,data(:,ia(i)),ja(:,ia(i)),vec_x(rowidx:),vec_y)
end if
#:endif
else
print *, "error: sellc format for spmv operation not yet supported."
return
end if
end associate
contains
#:for chunk in CHUNKS
pure subroutine chunk_kernel_${chunk}$(n,a,col,x,y)
integer, value :: n
${t1}$, intent(in) :: a(${chunk}$,n), x(:)
integer(ilp), intent(in) :: col(${chunk}$,n)
${t1}$, intent(inout) :: y(${chunk}$)
integer :: j
do j = 1, n
y(:) = y(:) + alpha_ * a(:,j) * x(col(:,j))
end do
end subroutine
pure subroutine chunk_kernel_trans_${chunk}$(n,a,col,x,y)
integer, value :: n
${t1}$, intent(in) :: a(${chunk}$,n), x(${chunk}$)
integer(ilp), intent(in) :: col(${chunk}$,n)
${t1}$, intent(inout) :: y(:)
integer :: j, k
do j = 1, n
do k = 1, ${chunk}$
y(col(k,j)) = y(col(k,j)) + alpha_ * a(k,j) * x(k)
end do
end do
end subroutine
#:if t1.startswith('complex')
pure subroutine chunk_kernel_herm_${chunk}$(n,a,col,x,y)
integer, value :: n
${t1}$, intent(in) :: a(${chunk}$,n), x(${chunk}$)
integer(ilp), intent(in) :: col(${chunk}$,n)
${t1}$, intent(inout) :: y(:)
integer :: j, k
do j = 1, n
do k = 1, ${chunk}$
y(col(k,j)) = y(col(k,j)) + alpha_ * conjg(a(k,j)) * x(k)
end do
end do
end subroutine
#:endif
#:endfor
pure subroutine chunk_kernel_rm(n,cs,r,a,col,x,y)
integer, value :: n, cs, r
${t1}$, intent(in) :: a(cs,n), x(:)
integer(ilp), intent(in) :: col(cs,n)
${t1}$, intent(inout) :: y(r)
integer :: j
do j = 1, n
y(1:r) = y(1:r) + alpha_ * a(1:r,j) * x(col(1:r,j))
end do
end subroutine
pure subroutine chunk_kernel_rm_trans(n,cs,r,a,col,x,y)
integer, value :: n, cs, r
${t1}$, intent(in) :: a(cs,n), x(r)
integer(ilp), intent(in) :: col(cs,n)
${t1}$, intent(inout) :: y(:)
integer :: j, k
do j = 1, n
do k = 1, r
y(col(k,j)) = y(col(k,j)) + alpha_ * a(k,j) * x(k)
end do
end do
end subroutine
#:if t1.startswith('complex')
pure subroutine chunk_kernel_rm_herm(n,cs,r,a,col,x,y)
integer, value :: n, cs, r
${t1}$, intent(in) :: a(cs,n), x(r)
integer(ilp), intent(in) :: col(cs,n)
${t1}$, intent(inout) :: y(:)
integer :: j, k
do j = 1, n
do k = 1, r
y(col(k,j)) = y(col(k,j)) + alpha_ * conjg(a(k,j)) * x(k)
end do
end do
end subroutine
#:endif
end subroutine
#:endfor
end module
fortran-lang-stdlib-0ede301/src/sparse/CMakeLists.txt 0000664 0001750 0001750 00000000653 15135654166 023016 0 ustar alastair alastair set(sparse_fppFiles
stdlib_sparse_constants.fypp
stdlib_sparse_conversion.fypp
stdlib_sparse_kinds.fypp
stdlib_sparse_spmv.fypp
)
set(sparse_cppFiles
)
set(sparse_f90Files
stdlib_sparse.f90
)
configure_stdlib_target(${PROJECT_NAME}_sparse sparse_f90Files sparse_fppFiles sparse_cppFiles)
target_link_libraries(${PROJECT_NAME}_sparse PUBLIC ${PROJECT_NAME}_constants ${PROJECT_NAME}_sorting)
fortran-lang-stdlib-0ede301/src/sparse/stdlib_sparse_conversion.fypp 0000664 0001750 0001750 00000076600 15135654166 026266 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES
!! The `stdlib_sparse_conversion` submodule provides sparse to sparse matrix conversion utilities.
!!
! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose
module stdlib_sparse_conversion
use stdlib_sorting, only: sort
use stdlib_sparse_constants
use stdlib_sparse_kinds
implicit none
private
!! Sort arrays of a COO matrix
!!
interface sort_coo
module procedure :: sort_coo_unique
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: sort_coo_unique_${s1}$
#:endfor
end interface
!! version: experimental
!!
!! Conversion from dense to coo
!! Enables extracting the non-zero elements of a dense 2D matrix and
!! storing those values in a COO format. The coo matrix is (re)allocated on the fly.
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface dense2coo
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: dense2coo_${s1}$
#:endfor
end interface
public :: dense2coo
!! version: experimental
!!
!! Conversion from coo to dense
!! Enables creating a dense 2D matrix from the non-zero values stored in a COO format
!! The dense matrix can be allocated on the fly if not pre-allocated by the user.
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface coo2dense
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: coo2dense_${s1}$
#:endfor
end interface
public :: coo2dense
!! version: experimental
!!
!! Conversion from coo to csr
!! Enables transferring data from a COO matrix to a CSR matrix
!! under the hypothesis that the COO is already ordered.
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface coo2csr
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: coo2csr_${s1}$
#:endfor
end interface
public :: coo2csr
!! version: experimental
!!
!! Conversion from coo to csc
!! Enables transferring data from a COO matrix to a CSC matrix
!! under the hypothesis that the COO is already ordered.
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface coo2csc
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: coo2csc_${s1}$
#:endfor
end interface
public :: coo2csc
!! version: experimental
!!
!! Conversion from csr to dense
!! Enables creating a dense 2D matrix from the non-zero values stored in a CSR format
!! The dense matrix can be allocated on the fly if not pre-allocated by the user.
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface csr2dense
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: csr2dense_${s1}$
#:endfor
end interface
public :: csr2dense
!! version: experimental
!!
!! Conversion from csr to coo
!! Enables transferring data from a CSR matrix to a COO matrix
!! under the hypothesis that the CSR is already ordered.
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface csr2coo
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: csr2coo_${s1}$
#:endfor
end interface
public :: csr2coo
!! version: experimental
!!
!! Conversion from csr to ell
!! Enables transferring data from a CSR matrix to a ELL matrix
!! under the hypothesis that the CSR is already ordered.
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface csr2ell
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: csr2ell_${s1}$
#:endfor
end interface
public :: csr2ell
!! version: experimental
!!
!! Conversion from csr to SELL-C
!! Enables transferring data from a CSR matrix to a SELL-C matrix
!! It takes an optional parameter to decide the chunck size 4, 8 or 16
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface csr2sellc
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: csr2sellc_${s1}$
#:endfor
end interface
public :: csr2sellc
!! version: experimental
!!
!! Conversion from csc to coo
!! Enables transferring data from a CSC matrix to a COO matrix
!! under the hypothesis that the CSC is already ordered.
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface csc2coo
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: csc2coo_${s1}$
#:endfor
end interface
public :: csc2coo
!! version: experimental
!!
!! Extraction of diagonal values
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface diag
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: dense2diagonal_${s1}$
module procedure :: coo2diagonal_${s1}$
module procedure :: csr2diagonal_${s1}$
module procedure :: csc2diagonal_${s1}$
module procedure :: ell2diagonal_${s1}$
#:endfor
end interface
public :: diag
!! version: experimental
!!
!! Enable creating a sparse matrix from ijv (row,col,data) triplet
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
interface from_ijv
module procedure :: coo_from_ijv_type
#:for k1, t1, s1 in (KINDS_TYPES)
module procedure :: coo_from_ijv_${s1}$
module procedure :: csr_from_ijv_${s1}$
module procedure :: ell_from_ijv_${s1}$
module procedure :: sellc_from_ijv_${s1}$
#:endfor
end interface
public :: from_ijv
public :: coo2ordered
contains
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine dense2coo_${s1}$(dense,COO)
${t1}$, intent(in) :: dense(:,:)
type(COO_${s1}$_type), intent(out) :: COO
integer(ilp) :: num_rows, num_cols, nnz
integer(ilp) :: i, j, idx
num_rows = size(dense,dim=1)
num_cols = size(dense,dim=2)
nnz = count( abs(dense) > tiny(1._${k1}$) )
call COO%malloc(num_rows,num_cols,nnz)
idx = 1
do i = 1, num_rows
do j = 1, num_cols
if(abs(dense(i,j)) < tiny(1._${k1}$)) cycle
COO%index(1,idx) = i
COO%index(2,idx) = j
COO%data(idx) = dense(i,j)
idx = idx + 1
end do
end do
COO%is_sorted = .true.
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine coo2dense_${s1}$(COO,dense)
type(COO_${s1}$_type), intent(in) :: COO
${t1}$, allocatable, intent(out) :: dense(:,:)
integer(ilp) :: idx
if(.not.allocated(dense)) allocate(dense(COO%nrows,COO%nrows),source=zero_${s1}$)
do concurrent(idx = 1:COO%nnz)
dense( COO%index(1,idx) , COO%index(2,idx) ) = COO%data(idx)
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine coo2csr_${s1}$(COO,CSR)
type(COO_${s1}$_type), intent(in) :: COO
type(CSR_${s1}$_type), intent(out) :: CSR
integer(ilp) :: i
CSR%nnz = COO%nnz; CSR%nrows = COO%nrows; CSR%ncols = COO%ncols
CSR%storage = COO%storage
if( allocated(CSR%col) ) then
CSR%col(1:COO%nnz) = COO%index(2,1:COO%nnz)
CSR%rowptr(1:CSR%nrows) = 0
CSR%data(1:CSR%nnz) = COO%data(1:COO%nnz)
else
allocate( CSR%col(CSR%nnz) , source = COO%index(2,1:COO%nnz) )
allocate( CSR%rowptr(CSR%nrows+1) , source = 0 )
allocate( CSR%data(CSR%nnz) , source = COO%data(1:COO%nnz) )
end if
CSR%rowptr(1) = 1
do i = 1, COO%nnz
CSR%rowptr( COO%index(1,i)+1 ) = CSR%rowptr( COO%index(1,i)+1 ) + 1
end do
do i = 1, CSR%nrows
CSR%rowptr( i+1 ) = CSR%rowptr( i+1 ) + CSR%rowptr( i )
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine coo2csc_${s1}$(COO,CSC)
type(COO_${s1}$_type), intent(in) :: COO
type(CSC_${s1}$_type), intent(out) :: CSC
${t1}$, allocatable :: data(:)
integer(ilp), allocatable :: temp(:,:)
integer(ilp) :: i, nnz
CSC%nnz = COO%nnz; CSC%nrows = COO%nrows; CSC%ncols = COO%ncols
CSC%storage = COO%storage
allocate(temp(2,COO%nnz))
temp(1,1:COO%nnz) = COO%index(2,1:COO%nnz)
temp(2,1:COO%nnz) = COO%index(1,1:COO%nnz)
allocate(data, source = COO%data )
nnz = COO%nnz
call sort_coo_unique_${s1}$( temp, data, nnz, COO%nrows, COO%ncols )
if( allocated(CSC%row) ) then
CSC%row(1:COO%nnz) = temp(2,1:COO%nnz)
CSC%colptr(1:CSC%ncols) = 0
CSC%data(1:CSC%nnz) = data(1:COO%nnz)
else
allocate( CSC%row(CSC%nnz) , source = temp(2,1:COO%nnz) )
allocate( CSC%colptr(CSC%ncols+1) , source = 0 )
allocate( CSC%data(CSC%nnz) , source = data(1:COO%nnz) )
end if
CSC%colptr(1) = 1
do i = 1, COO%nnz
CSC%colptr( temp(1,i)+1 ) = CSC%colptr( temp(1,i)+1 ) + 1
end do
do i = 1, CSC%ncols
CSC%colptr( i+1 ) = CSC%colptr( i+1 ) + CSC%colptr( i )
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine csr2dense_${s1}$(CSR,dense)
type(CSR_${s1}$_type), intent(in) :: CSR
${t1}$, allocatable, intent(out) :: dense(:,:)
integer(ilp) :: i, j
if(.not.allocated(dense)) allocate(dense(CSR%nrows,CSR%nrows),source=zero_${s1}$)
if( CSR%storage == sparse_full) then
do i = 1, CSR%nrows
do j = CSR%rowptr(i), CSR%rowptr(i+1)-1
dense(i,CSR%col(j)) = CSR%data(j)
end do
end do
else
do i = 1, CSR%nrows
do j = CSR%rowptr(i), CSR%rowptr(i+1)-1
dense(i,CSR%col(j)) = CSR%data(j)
if( i == CSR%col(j) ) cycle
dense(CSR%col(j),i) = CSR%data(j)
end do
end do
end if
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine csr2coo_${s1}$(CSR,COO)
type(CSR_${s1}$_type), intent(in) :: CSR
type(COO_${s1}$_type), intent(out) :: COO
integer(ilp) :: i, j
COO%nnz = CSR%nnz; COO%nrows = CSR%nrows; COO%ncols = CSR%ncols
COO%storage = CSR%storage
if( .not.allocated(COO%data) ) then
allocate( COO%data(CSR%nnz) , source = CSR%data(1:CSR%nnz) )
else
COO%data(1:CSR%nnz) = CSR%data(1:CSR%nnz)
end if
if( .not.allocated(COO%index) ) allocate( COO%index(2,CSR%nnz) )
do i = 1, CSR%nrows
do j = CSR%rowptr(i), CSR%rowptr(i+1)-1
COO%index(1:2,j) = [i,CSR%col(j)]
end do
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine csc2coo_${s1}$(CSC,COO)
type(CSC_${s1}$_type), intent(in) :: CSC
type(COO_${s1}$_type), intent(out) :: COO
integer(ilp) :: i, j
COO%nnz = CSC%nnz; COO%nrows = CSC%nrows; COO%ncols = CSC%ncols
COO%storage = CSC%storage
if( .not.allocated(COO%data) ) then
allocate( COO%data(CSC%nnz) , source = CSC%data(1:CSC%nnz) )
else
COO%data(1:CSC%nnz) = CSC%data(1:CSC%nnz)
end if
if( .not.allocated(COO%index) ) allocate( COO%index(2,CSC%nnz) )
do j = 1, CSC%ncols
do i = CSC%colptr(j), CSC%colptr(j+1)-1
COO%index(1:2,i) = [CSC%row(i),j]
end do
end do
call sort_coo_unique_${s1}$( COO%index, COO%data, COO%nnz, COO%nrows, COO%ncols )
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine csr2ell_${s1}$(CSR,ELL,num_nz_rows)
type(CSR_${s1}$_type), intent(in) :: CSR
type(ELL_${s1}$_type), intent(out) :: ELL
integer, intent(in), optional :: num_nz_rows !! number of non zeros per row
integer(ilp) :: i, j, num_nz_rows_, adr1, adr2
!-------------------------------------------
num_nz_rows_ = 0
if(present(num_nz_rows)) then
num_nz_rows_ = num_nz_rows
else
do i = 1, CSR%nrows
num_nz_rows_ = max(num_nz_rows_, CSR%rowptr( i+1 ) - CSR%rowptr( i ) )
end do
end if
call ELL%malloc(CSR%nrows,CSR%ncols,num_nz_rows_)
ELL%storage = CSR%storage
!-------------------------------------------
do i = 1, CSR%nrows
adr1 = CSR%rowptr(i)
adr2 = min( adr1+num_nz_rows_ , CSR%rowptr(i+1)-1)
do j = adr1, adr2
ELL%index(i,j-adr1+1) = CSR%col(j)
ELL%data(i,j-adr1+1) = CSR%data(j)
end do
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine csr2sellc_${s1}$(CSR,SELLC,chunk)
!! csr2sellc: This function enables transfering data from a CSR matrix to a SELL-C matrix
!! This algorithm was gracefully provided by Ivan Privec and adapted by Jose Alves
type(CSR_${s1}$_type), intent(in) :: CSR
type(SELLC_${s1}$_type), intent(out) :: SELLC
integer, intent(in), optional :: chunk
${t1}$, parameter :: zero = zero_${s1}$
integer(ilp) :: i, j, num_chunks
if(present(chunk)) SELLC%chunk_size = chunk
SELLC%nrows = CSR%nrows; SELLC%ncols = CSR%ncols
SELLC%storage = CSR%storage
associate( nrows=>SELLC%nrows, ncols=>SELLC%ncols, nnz=>SELLC%nnz, &
& chunk_size=>SELLC%chunk_size )
!-------------------------------------------
! csr rowptr to SELL-C chunked rowptr
num_chunks = (nrows + chunk_size - 1)/chunk_size
allocate( SELLC%rowptr(num_chunks+1) )
block
integer :: cidx, rownnz, chunknnz
SELLC%rowptr(1) = 1
cidx = 1
do i = 1, nrows, chunk_size
chunknnz = 0
! Iterate over rows in a given chunk
do j = i, min(i+chunk_size-1,nrows)
rownnz = CSR%rowptr(j+1) - CSR%rowptr(j)
chunknnz = max(chunknnz,rownnz)
end do
SELLC%rowptr(cidx+1) = SELLC%rowptr(cidx) + chunknnz
cidx = cidx + 1
end do
nnz = SELLC%rowptr(num_chunks+1) - 1
end block
!-------------------------------------------
! copy values and colum index
allocate(SELLC%col(chunk_size,nnz), source = 1)
allocate(SELLC%data(chunk_size,nnz), source = zero )
block
integer :: lb, ri, iaa, iab, rownnz
do i = 1, num_chunks
lb = SELLC%rowptr(i)
! Loop over rows of a chunk
do j = (i-1)*chunk_size + 1, min(i*chunk_size,nrows)
ri = j - (i - 1)*chunk_size
rownnz = CSR%rowptr(j+1) - CSR%rowptr(j) - 1
iaa = CSR%rowptr(j)
iab = CSR%rowptr(j+1) - 1
SELLC%col(ri,lb:lb+rownnz) = CSR%col(iaa:iab)
SELLC%data(ri,lb:lb+rownnz) = CSR%data(iaa:iab)
end do
end do
end block
end associate
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
recursive subroutine quicksort_i_${s1}$(a, b, first, last)
integer(ilp), intent(inout) :: a(*) !! reference table to sort
${t1}$, intent(inout) :: b(*) !! secondary real data to sort w.r.t. a
integer(ilp), intent(in) :: first, last
integer(ilp) :: i, j, x, t
${t1}$ :: d
x = a( (first+last) / 2 )
i = first
j = last
do
do while (a(i) < x)
i=i+1
end do
do while (x < a(j))
j=j-1
end do
if (i >= j) exit
t = a(i); a(i) = a(j); a(j) = t
d = b(i); b(i) = b(j); b(j) = d
i=i+1
j=j-1
end do
if (first < i-1) call quicksort_i_${s1}$(a, b, first, i-1)
if (j+1 < last) call quicksort_i_${s1}$(a, b, j+1, last)
end subroutine
#:endfor
subroutine sort_coo_unique( a, n, num_rows, num_cols )
!! Sort a 2d array in increasing order first by index 1 and then by index 2
integer(ilp), intent(inout) :: a(2,*)
integer(ilp), intent(inout) :: n
integer(ilp), intent(in) :: num_rows
integer(ilp), intent(in) :: num_cols
integer(ilp) :: stride, adr0, adr1, dd
integer(ilp) :: n_i, pos, ed
integer(ilp), allocatable :: count_i(:), count_i_aux(:), rows_(:), cols_(:)
!---------------------------------------------------------
! Sort a first time with respect to first index using count sort
allocate( count_i( 0:num_rows ) , source = 0 )
do ed = 1, n
count_i( a(1,ed) ) = count_i( a(1,ed) ) + 1
end do
do n_i = 2, num_rows
count_i(n_i) = count_i(n_i) + count_i(n_i-1)
end do
allocate( count_i_aux( 0:num_rows ) , source = count_i )
allocate( rows_(n), cols_(n) )
do ed = n, 1, -1
n_i = a(1,ed)
pos = count_i(n_i)
rows_(pos) = a(1,ed)
cols_(pos) = a(2,ed)
count_i(n_i) = count_i(n_i) - 1
end do
!---------------------------------------------------------
! Sort with respect to second column
do n_i = 1, num_rows
adr0 = count_i_aux(n_i-1)+1
adr1 = count_i_aux(n_i)
dd = adr1-adr0+1
if(dd>0) call sort(cols_(adr0:adr1))
end do
!---------------------------------------------------------
! Remove duplicates
do ed = 1,n
a(1:2,ed) = [rows_(ed),cols_(ed)]
end do
stride = 0
do ed = 2, n
if( a(1,ed) == a(1,ed-1) .and. a(2,ed) == a(2,ed-1) ) then
stride = stride + 1
else
a(1:2,ed-stride) = a(1:2,ed)
end if
end do
n = n - stride
end subroutine
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine sort_coo_unique_${s1}$( a, data, n, num_rows, num_cols )
!! Sort a 2d array in increasing order first by index 1 and then by index 2
${t1}$, intent(inout) :: data(*)
integer(ilp), intent(inout) :: a(2,*)
integer(ilp), intent(inout) :: n
integer(ilp), intent(in) :: num_rows
integer(ilp), intent(in) :: num_cols
integer(ilp) :: stride, adr0, adr1, dd
integer(ilp) :: n_i, pos, ed
integer(ilp), allocatable :: count_i(:), count_i_aux(:), rows_(:), cols_(:)
${t1}$, allocatable :: temp(:)
!---------------------------------------------------------
! Sort a first time with respect to first index using Count sort
allocate( count_i( 0:num_rows ) , source = 0 )
do ed = 1, n
count_i( a(1,ed) ) = count_i( a(1,ed) ) + 1
end do
do n_i = 2, num_rows
count_i(n_i) = count_i(n_i) + count_i(n_i-1)
end do
allocate( count_i_aux( 0:num_rows ) , source = count_i )
allocate( rows_(n), cols_(n), temp(n) )
do ed = n, 1, -1
n_i = a(1,ed)
pos = count_i(n_i)
rows_(pos) = a(1,ed)
cols_(pos) = a(2,ed)
temp(pos) = data(ed)
count_i(n_i) = count_i(n_i) - 1
end do
!---------------------------------------------------------
! Sort with respect to second colum using a quicksort
do n_i = 1, num_rows
adr0 = count_i_aux(n_i-1)+1
adr1 = count_i_aux(n_i)
dd = adr1-adr0+1
if(dd>0) call quicksort_i_${s1}$(cols_(adr0),temp(adr0),1,dd)
end do
!---------------------------------------------------------
! Remove duplicates
do ed = 1,n
a(1:2,ed) = [rows_(ed),cols_(ed)]
end do
data(1:n) = temp(1:n)
stride = 0
do ed = 2, n
if( a(1,ed) == a(1,ed-1) .and. a(2,ed) == a(2,ed-1) ) then
data(ed-1-stride) = data(ed-1-stride) + data(ed)
data(ed) = data(ed-1-stride)
stride = stride + 1
else
a(1:2,ed-stride) = a(1:2,ed)
data(ed-stride) = data(ed)
end if
end do
n = n - stride
end subroutine
#:endfor
!! version: experimental
!!
!! Transform COO matrix to canonical form with ordered and unique entries
!! [Specifications](../page/specs/stdlib_sparse.html#sparse_conversion)
subroutine coo2ordered(COO,sort_data)
class(COO_type), intent(inout) :: COO
logical, intent(in), optional :: sort_data
integer(ilp), allocatable :: itemp(:,:)
logical :: sort_data_
if(COO%is_sorted) return
sort_data_ = .false.
if(present(sort_data)) sort_data_ = sort_data
select type (COO)
type is( COO_type )
call sort_coo(COO%index, COO%nnz, COO%nrows, COO%ncols)
#:for k1, t1, s1 in (KINDS_TYPES)
type is( COO_${s1}$_type )
block
${t1}$, allocatable :: temp(:)
if( sort_data_ ) then
call sort_coo(COO%index, COO%data, COO%nnz, COO%nrows, COO%ncols)
allocate( temp(COO%nnz) , source=COO%data(1:COO%nnz) )
else
call sort_coo(COO%index, COO%nnz, COO%nrows, COO%ncols)
allocate( temp(COO%nnz) )
end if
call move_alloc( temp , COO%data )
end block
#:endfor
end select
allocate( itemp(2,COO%nnz) , source=COO%index(1:2,1:COO%nnz) )
call move_alloc( itemp , COO%index )
COO%is_sorted = .true.
end subroutine
subroutine coo_from_ijv_type(COO,row,col,nrows,ncols)
type(COO_type), intent(inout) :: COO
integer(ilp), intent(in) :: row(:)
integer(ilp), intent(in) :: col(:)
integer(ilp), intent(in), optional :: nrows
integer(ilp), intent(in), optional :: ncols
integer(ilp) :: nrows_, ncols_, nnz, ed
!---------------------------------------------------------
if(present(nrows)) then
nrows_ = nrows
else
nrows_ = size(row)
end if
if(present(ncols)) then
ncols_ = ncols
else
ncols_ = size(col)
end if
nnz = size(row)
!---------------------------------------------------------
call COO%malloc(nrows_,ncols_,nnz)
do ed = 1, nnz
COO%index(1:2,ed) = [row(ed),col(ed)]
end do
call coo2ordered(COO,.true.)
end subroutine
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine coo_from_ijv_${s1}$(COO,row,col,data,nrows,ncols)
type(COO_${s1}$_type), intent(inout) :: COO
integer(ilp), intent(in) :: row(:)
integer(ilp), intent(in) :: col(:)
${t1}$, intent(in), optional :: data(:)
integer(ilp), intent(in), optional :: nrows
integer(ilp), intent(in), optional :: ncols
integer(ilp) :: nrows_, ncols_, nnz, ed
!---------------------------------------------------------
if(present(nrows)) then
nrows_ = nrows
else
nrows_ = maxval(row)
end if
if(present(ncols)) then
ncols_ = ncols
else
ncols_ = maxval(col)
end if
nnz = size(row)
!---------------------------------------------------------
call COO%malloc(nrows_,ncols_,nnz)
do ed = 1, nnz
COO%index(1:2,ed) = [row(ed),col(ed)]
end do
if(present(data)) COO%data = data
call coo2ordered(COO,.true.)
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine csr_from_ijv_${s1}$(CSR,row,col,data,nrows,ncols)
type(CSR_${s1}$_type), intent(inout) :: CSR
integer(ilp), intent(in) :: row(:)
integer(ilp), intent(in) :: col(:)
${t1}$, intent(in), optional :: data(:)
integer(ilp), intent(in), optional :: nrows
integer(ilp), intent(in), optional :: ncols
integer(ilp) :: nrows_, ncols_
!---------------------------------------------------------
if(present(nrows)) then
nrows_ = nrows
else
nrows_ = maxval(row)
end if
if(present(ncols)) then
ncols_ = ncols
else
ncols_ = maxval(col)
end if
!---------------------------------------------------------
block
type(COO_${s1}$_type) :: COO
if(present(data)) then
call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_)
else
call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_)
end if
call coo2csr(COO,CSR)
end block
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine ell_from_ijv_${s1}$(ELL,row,col,data,nrows,ncols,num_nz_rows)
type(ELL_${s1}$_type), intent(inout) :: ELL
integer(ilp), intent(in) :: row(:)
integer(ilp), intent(in) :: col(:)
${t1}$, intent(in), optional :: data(:)
integer(ilp), intent(in), optional :: nrows
integer(ilp), intent(in), optional :: ncols
integer, intent(in), optional :: num_nz_rows
integer(ilp) :: nrows_, ncols_
!---------------------------------------------------------
if(present(nrows)) then
nrows_ = nrows
else
nrows_ = maxval(row)
end if
if(present(ncols)) then
ncols_ = ncols
else
ncols_ = maxval(col)
end if
!---------------------------------------------------------
block
type(COO_${s1}$_type) :: COO
type(CSR_${s1}$_type) :: CSR
if(present(data)) then
call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_)
else
call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_)
end if
call coo2csr(COO,CSR)
if(present(num_nz_rows)) then
call csr2ell(CSR,ELL,num_nz_rows)
else
call csr2ell(CSR,ELL)
end if
end block
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine sellc_from_ijv_${s1}$(SELLC,row,col,data,nrows,ncols,chunk)
type(SELLC_${s1}$_type), intent(inout) :: SELLC
integer(ilp), intent(in) :: row(:)
integer(ilp), intent(in) :: col(:)
${t1}$, intent(in), optional :: data(:)
integer(ilp), intent(in), optional :: nrows
integer(ilp), intent(in), optional :: ncols
integer, intent(in), optional :: chunk
integer(ilp) :: nrows_, ncols_
!---------------------------------------------------------
if(present(nrows)) then
nrows_ = nrows
else
nrows_ = maxval(row)
end if
if(present(ncols)) then
ncols_ = ncols
else
ncols_ = maxval(col)
end if
if(present(chunk)) SELLC%chunk_size = chunk
!---------------------------------------------------------
block
type(COO_${s1}$_type) :: COO
type(CSR_${s1}$_type) :: CSR
if(present(data)) then
call from_ijv(COO,row,col,data=data,nrows=nrows_,ncols=ncols_)
else
call from_ijv(COO,row,col,nrows=nrows_,ncols=ncols_)
end if
call coo2csr(COO,CSR)
call csr2sellc(CSR,SELLC)
end block
end subroutine
#:endfor
!! Diagonal extraction
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine dense2diagonal_${s1}$(dense,diagonal)
${t1}$, intent(in) :: dense(:,:)
${t1}$, intent(inout), allocatable :: diagonal(:)
integer :: num_rows
integer :: i
num_rows = size(dense,dim=1)
if(.not.allocated(diagonal)) allocate(diagonal(num_rows))
do i = 1, num_rows
diagonal(i) = dense(i,i)
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine coo2diagonal_${s1}$(COO,diagonal)
type(COO_${s1}$_type), intent(in) :: COO
${t1}$, intent(inout), allocatable :: diagonal(:)
integer :: idx
if(.not.allocated(diagonal)) allocate(diagonal(COO%nrows))
do concurrent(idx = 1:COO%nnz)
if(COO%index(1,idx)==COO%index(2,idx)) &
& diagonal( COO%index(1,idx) ) = COO%data(idx)
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine csr2diagonal_${s1}$(CSR,diagonal)
type(CSR_${s1}$_type), intent(in) :: CSR
${t1}$, intent(inout), allocatable :: diagonal(:)
integer :: i, j
if(.not.allocated(diagonal)) allocate(diagonal(CSR%nrows))
select case(CSR%storage)
case(sparse_lower)
do i = 1, CSR%nrows
diagonal(i) = CSR%data( CSR%rowptr(i+1)-1 )
end do
case(sparse_upper)
do i = 1, CSR%nrows
diagonal(i) = CSR%data( CSR%rowptr(i) )
end do
case(sparse_full)
do i = 1, CSR%nrows
do j = CSR%rowptr(i), CSR%rowptr(i+1)-1
if( CSR%col(j) == i ) then
diagonal(i) = CSR%data(j)
exit
end if
end do
end do
end select
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine csc2diagonal_${s1}$(CSC,diagonal)
type(CSC_${s1}$_type), intent(in) :: CSC
${t1}$, intent(inout), allocatable :: diagonal(:)
integer :: i, j
if(.not.allocated(diagonal)) allocate(diagonal(CSC%nrows))
select case(CSC%storage)
case(sparse_lower)
do i = 1, CSC%ncols
diagonal(i) = CSC%data( CSC%colptr(i+1)-1 )
end do
case(sparse_upper)
do i = 1, CSC%ncols
diagonal(i) = CSC%data( CSC%colptr(i) )
end do
case(sparse_full)
do i = 1, CSC%ncols
do j = CSC%colptr(i), CSC%colptr(i+1)-1
if( CSC%row(j) == i ) then
diagonal(i) = CSC%data(j)
exit
end if
end do
end do
end select
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
subroutine ell2diagonal_${s1}$(ELL,diagonal)
type(ELL_${s1}$_type), intent(in) :: ELL
${t1}$, intent(inout), allocatable :: diagonal(:)
integer :: i, k
if(.not.allocated(diagonal)) allocate(diagonal(ELL%nrows))
if( ELL%storage == sparse_full) then
do i = 1, ELL%nrows
do k = 1, ELL%K
if(ELL%index(i,k)==i) diagonal(i) = ELL%data(i,k)
end do
end do
end if
end subroutine
#:endfor
end module fortran-lang-stdlib-0ede301/src/sparse/stdlib_sparse_kinds.fypp 0000664 0001750 0001750 00000052060 15135654166 025203 0 ustar alastair alastair #:include "common.fypp"
#:set RANKS = range(1, 2+1)
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
#:set KINDS_TYPES = R_KINDS_TYPES+C_KINDS_TYPES
!! The `stdlib_sparse_kinds` module provides derived type definitions for different sparse matrices
!!
! This code was modified from https://github.com/jalvesz/FSPARSE by its author: Alves Jose
module stdlib_sparse_kinds
use ieee_arithmetic
use stdlib_sparse_constants
implicit none
private
public :: sparse_full, sparse_lower, sparse_upper
public :: sparse_op_none, sparse_op_transpose, sparse_op_hermitian
!! version: experimental
!!
!! Base sparse type holding the meta data related to the storage capacity of a matrix.
type, public, abstract :: sparse_type
integer(ilp) :: nrows = 0 !! number of rows
integer(ilp) :: ncols = 0 !! number of columns
integer(ilp) :: nnz = 0 !! number of non-zero values
integer :: storage = sparse_full !! assumed storage symmetry
end type
!! version: experimental
!!
!! COO: COOrdinates compresed format
type, public, extends(sparse_type) :: COO_type
logical :: is_sorted = .false. !! whether the matrix is sorted or not
integer(ilp), allocatable :: index(:,:) !! Matrix coordinates index(2,nnz)
contains
procedure :: malloc => malloc_coo
end type
#:for k1, t1, s1 in (KINDS_TYPES)
type, public, extends(COO_type) :: COO_${s1}$_type
${t1}$, allocatable :: data(:)
contains
procedure, non_overridable :: at => at_value_coo_${s1}$
procedure, non_overridable :: add_value => add_value_coo_${s1}$
procedure, non_overridable :: add_block => add_block_coo_${s1}$
generic :: add => add_value, add_block
end type
#:endfor
!! version: experimental
!!
!! CSR: Compressed sparse row or Yale format
type, public, extends(sparse_type) :: CSR_type
integer(ilp), allocatable :: col(:) !! matrix column pointer
integer(ilp), allocatable :: rowptr(:) !! matrix row pointer
contains
procedure :: malloc => malloc_csr
end type
#:for k1, t1, s1 in (KINDS_TYPES)
type, public, extends(CSR_type) :: CSR_${s1}$_type
${t1}$, allocatable :: data(:)
contains
procedure, non_overridable :: at => at_value_csr_${s1}$
procedure, non_overridable :: add_value => add_value_csr_${s1}$
procedure, non_overridable :: add_block => add_block_csr_${s1}$
generic :: add => add_value, add_block
end type
#:endfor
!! version: experimental
!!
!! CSC: Compressed sparse column
type, public, extends(sparse_type) :: CSC_type
integer(ilp), allocatable :: colptr(:) !! matrix column pointer
integer(ilp), allocatable :: row(:) !! matrix row pointer
contains
procedure :: malloc => malloc_csc
end type
#:for k1, t1, s1 in (KINDS_TYPES)
type, public, extends(CSC_type) :: CSC_${s1}$_type
${t1}$, allocatable :: data(:)
contains
procedure, non_overridable :: at => at_value_csc_${s1}$
procedure, non_overridable :: add_value => add_value_csc_${s1}$
procedure, non_overridable :: add_block => add_block_csc_${s1}$
generic :: add => add_value, add_block
end type
#:endfor
!! version: experimental
!!
!! Compressed ELLPACK
type, public, extends(sparse_type) :: ELL_type
integer :: K = 0 !! maximum number of nonzeros per row
integer(ilp), allocatable :: index(:,:) !! column indices
contains
procedure :: malloc => malloc_ell
end type
#:for k1, t1, s1 in (KINDS_TYPES)
type, public, extends(ELL_type) :: ELL_${s1}$_type
${t1}$, allocatable :: data(:,:)
contains
procedure, non_overridable :: at => at_value_ell_${s1}$
procedure, non_overridable :: add_value => add_value_ell_${s1}$
procedure, non_overridable :: add_block => add_block_ell_${s1}$
generic :: add => add_value, add_block
end type
#:endfor
!! version: experimental
!!
!! Compressed SELL-C
!! Reference : https://library.eecs.utk.edu/storage/files/ut-eecs-14-727.pdf
type, public, extends(sparse_type) :: SELLC_type
integer :: chunk_size = 8 !! default chunk size
integer(ilp), allocatable :: rowptr(:) !! row pointer
integer(ilp), allocatable :: col(:,:) !! column indices
end type
#:for k1, t1, s1 in (KINDS_TYPES)
type, public, extends(SELLC_type) :: SELLC_${s1}$_type
${t1}$, allocatable :: data(:,:)
contains
procedure, non_overridable :: at => at_value_sellc_${s1}$
procedure, non_overridable :: add_value => add_value_sellc_${s1}$
procedure, non_overridable :: add_block => add_block_sellc_${s1}$
generic :: add => add_value, add_block
end type
#:endfor
contains
!! (re)Allocate matrix memory for the COO type
subroutine malloc_coo(self,num_rows,num_cols,nnz)
class(COO_type) :: self
integer(ilp), intent(in) :: num_rows !! number of rows
integer(ilp), intent(in) :: num_cols !! number of columns
integer(ilp), intent(in) :: nnz !! number of non zeros
integer(ilp), allocatable :: temp_idx(:,:)
!-----------------------------------------------------
self%nrows = num_rows
self%ncols = num_cols
self%nnz = nnz
if(.not.allocated(self%index)) then
allocate(temp_idx(2,nnz) , source = 0 )
else
allocate(temp_idx(2,nnz) , source = self%index )
end if
call move_alloc(from=temp_idx,to=self%index)
select type(self)
#:for k1, t1, s1 in (KINDS_TYPES)
type is(COO_${s1}$_type)
block
${t1}$, allocatable :: temp_data_${s1}$(:)
if(.not.allocated(self%data)) then
allocate(temp_data_${s1}$(nnz) , source = zero_${s1}$ )
else
allocate(temp_data_${s1}$(nnz) , source = self%data )
end if
call move_alloc(from=temp_data_${s1}$,to=self%data)
end block
#:endfor
end select
end subroutine
!! (re)Allocate matrix memory for the CSR type
subroutine malloc_csr(self,num_rows,num_cols,nnz)
class(CSR_type) :: self
integer(ilp), intent(in) :: num_rows !! number of rows
integer(ilp), intent(in) :: num_cols !! number of columns
integer(ilp), intent(in) :: nnz !! number of non zeros
integer(ilp), allocatable :: temp_idx(:)
!-----------------------------------------------------
self%nrows = num_rows
self%ncols = num_cols
self%nnz = nnz
if(.not.allocated(self%col)) then
allocate(temp_idx(nnz) , source = 0 )
else
allocate(temp_idx(nnz) , source = self%col )
end if
call move_alloc(from=temp_idx,to=self%col)
if(.not.allocated(self%rowptr)) then
allocate(temp_idx(num_rows+1) , source = 0 )
else
allocate(temp_idx(num_rows+1) , source = self%rowptr )
end if
call move_alloc(from=temp_idx,to=self%rowptr)
select type(self)
#:for k1, t1, s1 in (KINDS_TYPES)
type is(CSR_${s1}$_type)
block
${t1}$, allocatable :: temp_data_${s1}$(:)
if(.not.allocated(self%data)) then
allocate(temp_data_${s1}$(nnz) , source = zero_${s1}$ )
else
allocate(temp_data_${s1}$(nnz) , source = self%data )
end if
call move_alloc(from=temp_data_${s1}$,to=self%data)
end block
#:endfor
end select
end subroutine
!! (re)Allocate matrix memory for the CSC type
subroutine malloc_csc(self,num_rows,num_cols,nnz)
class(CSC_type) :: self
integer(ilp), intent(in) :: num_rows !! number of rows
integer(ilp), intent(in) :: num_cols !! number of columns
integer(ilp), intent(in) :: nnz !! number of non zeros
integer(ilp), allocatable :: temp_idx(:)
!-----------------------------------------------------
self%nrows = num_rows
self%ncols = num_cols
self%nnz = nnz
if(.not.allocated(self%row)) then
allocate(temp_idx(nnz) , source = 0 )
else
allocate(temp_idx(nnz) , source = self%row )
end if
call move_alloc(from=temp_idx,to=self%row)
if(.not.allocated(self%colptr)) then
allocate(temp_idx(num_cols+1) , source = 0 )
else
allocate(temp_idx(num_cols+1) , source = self%colptr )
end if
call move_alloc(from=temp_idx,to=self%colptr)
select type(self)
#:for k1, t1, s1 in (KINDS_TYPES)
type is(CSC_${s1}$_type)
block
${t1}$, allocatable :: temp_data_${s1}$(:)
if(.not.allocated(self%data)) then
allocate(temp_data_${s1}$(nnz) , source = zero_${s1}$ )
else
allocate(temp_data_${s1}$(nnz) , source = self%data )
end if
call move_alloc(from=temp_data_${s1}$,to=self%data)
end block
#:endfor
end select
end subroutine
!! (re)Allocate matrix memory for the ELLPACK type
subroutine malloc_ell(self,num_rows,num_cols,num_nz_rows)
class(ELL_type) :: self
integer(ilp), intent(in) :: num_rows !! number of rows
integer(ilp), intent(in) :: num_cols !! number of columns
integer(ilp), intent(in) :: num_nz_rows !! number of non zeros per row
integer(ilp), allocatable :: temp_idx(:,:)
!-----------------------------------------------------
self%nrows = num_rows
self%ncols = num_cols
self%K = num_nz_rows
if(.not.allocated(self%index)) then
allocate(temp_idx(num_rows,num_nz_rows) , source = 0 )
else
allocate(temp_idx(num_rows,num_nz_rows) , source = self%index )
end if
call move_alloc(from=temp_idx,to=self%index)
select type(self)
#:for k1, t1, s1 in (KINDS_TYPES)
type is(ELL_${s1}$_type)
block
${t1}$, allocatable :: temp_data_${s1}$(:,:)
if(.not.allocated(self%data)) then
allocate(temp_data_${s1}$(num_rows,num_nz_rows) , source = zero_${s1}$ )
else
allocate(temp_data_${s1}$(num_rows,num_nz_rows) , source = self%data )
end if
call move_alloc(from=temp_data_${s1}$,to=self%data)
end block
#:endfor
end select
end subroutine
!==================================================================
! data accessors
!==================================================================
#:for k1, t1, s1 in (KINDS_TYPES)
pure ${t1}$ function at_value_coo_${s1}$(self,ik,jk) result(val)
class(COO_${s1}$_type), intent(in) :: self
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k, ik_, jk_
logical :: transpose
! naive implementation
if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then
val = ieee_value( 0._${k1}$ , ieee_quiet_nan)
return
end if
ik_ = ik; jk_ = jk
transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk)
if(transpose) then ! allow extraction of symmetric elements
ik_ = jk; jk_ = ik
end if
do k = 1, self%nnz
if( ik_ == self%index(1,k) .and. jk_ == self%index(2,k) ) then
val = self%data(k)
return
end if
end do
val = zero_${s1}$
end function
subroutine add_value_coo_${s1}$(self,ik,jk,val)
class(COO_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k
! naive implementation
do k = 1,self%nnz
if( ik == self%index(1,k) .and. jk == self%index(2,k) ) then
self%data(k) = self%data(k) + val
return
end if
end do
end subroutine
subroutine add_block_coo_${s1}$(self,ik,jk,val)
class(COO_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val(:,:)
integer(ilp), intent(in) :: ik(:), jk(:)
integer(ilp) :: k, i, j
! naive implementation
do k = 1, self%nnz
do i = 1, size(ik)
if( ik(i) /= self%index(1,k) ) cycle
do j = 1, size(jk)
if( jk(j) /= self%index(2,k) ) cycle
self%data(k) = self%data(k) + val(i,j)
end do
end do
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
pure ${t1}$ function at_value_csr_${s1}$(self,ik,jk) result(val)
class(CSR_${s1}$_type), intent(in) :: self
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k, ik_, jk_
logical :: transpose
! naive implementation
if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then
val = ieee_value( 0._${k1}$ , ieee_quiet_nan)
return
end if
ik_ = ik; jk_ = jk
transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk)
if(transpose) then ! allow extraction of symmetric elements
ik_ = jk; jk_ = ik
end if
do k = self%rowptr(ik_), self%rowptr(ik_+1)-1
if( jk_ == self%col(k) ) then
val = self%data(k)
return
end if
end do
val = zero_${s1}$
end function
subroutine add_value_csr_${s1}$(self,ik,jk,val)
class(CSR_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k
! naive implementation
do k = self%rowptr(ik), self%rowptr(ik+1)-1
if( jk == self%col(k) ) then
self%data(k) = self%data(k) + val
return
end if
end do
end subroutine
subroutine add_block_csr_${s1}$(self,ik,jk,val)
class(CSR_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val(:,:)
integer(ilp), intent(in) :: ik(:), jk(:)
integer(ilp) :: k, i, j
! naive implementation
do i = 1, size(ik)
do k = self%rowptr(ik(i)), self%rowptr(ik(i)+1)-1
do j = 1, size(jk)
if( jk(j) == self%col(k) ) then
self%data(k) = self%data(k) + val(i,j)
end if
end do
end do
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
pure ${t1}$ function at_value_csc_${s1}$(self,ik,jk) result(val)
class(CSC_${s1}$_type), intent(in) :: self
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k, ik_, jk_
logical :: transpose
! naive implementation
if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then
val = ieee_value( 0._${k1}$ , ieee_quiet_nan)
return
end if
ik_ = ik; jk_ = jk
transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk)
if(transpose) then ! allow extraction of symmetric elements
ik_ = jk; jk_ = ik
end if
do k = self%colptr(jk_), self%colptr(jk_+1)-1
if( ik_ == self%row(k) ) then
val = self%data(k)
return
end if
end do
val = zero_${s1}$
end function
subroutine add_value_csc_${s1}$(self,ik,jk,val)
class(CSC_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k
! naive implementation
do k = self%colptr(jk), self%colptr(jk+1)-1
if( ik == self%row(k) ) then
self%data(k) = self%data(k) + val
return
end if
end do
end subroutine
subroutine add_block_csc_${s1}$(self,ik,jk,val)
class(CSC_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val(:,:)
integer(ilp), intent(in) :: ik(:), jk(:)
integer(ilp) :: k, i, j
! naive implementation
do j = 1, size(jk)
do k = self%colptr(jk(j)), self%colptr(jk(j)+1)-1
do i = 1, size(ik)
if( ik(i) == self%row(k) ) then
self%data(k) = self%data(k) + val(i,j)
end if
end do
end do
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
pure ${t1}$ function at_value_ell_${s1}$(self,ik,jk) result(val)
class(ELL_${s1}$_type), intent(in) :: self
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k, ik_, jk_
logical :: transpose
! naive implementation
if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then
val = ieee_value( 0._${k1}$ , ieee_quiet_nan)
return
end if
ik_ = ik; jk_ = jk
transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk)
if(transpose) then ! allow extraction of symmetric elements
ik_ = jk; jk_ = ik
end if
do k = 1 , self%K
if( jk_ == self%index(ik_,k) ) then
val = self%data(ik_,k)
return
end if
end do
val = zero_${s1}$
end function
subroutine add_value_ell_${s1}$(self,ik,jk,val)
class(ELL_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k
! naive implementation
do k = 1 , self%K
if( jk == self%index(ik,k) ) then
self%data(ik,k) = self%data(ik,k) + val
return
end if
end do
end subroutine
subroutine add_block_ell_${s1}$(self,ik,jk,val)
class(ELL_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val(:,:)
integer(ilp), intent(in) :: ik(:), jk(:)
integer(ilp) :: k, i, j
! naive implementation
do k = 1 , self%K
do j = 1, size(jk)
do i = 1, size(ik)
if( jk(j) == self%index(ik(i),k) ) then
self%data(ik(i),k) = self%data(ik(i),k) + val(i,j)
end if
end do
end do
end do
end subroutine
#:endfor
#:for k1, t1, s1 in (KINDS_TYPES)
pure ${t1}$ function at_value_sellc_${s1}$(self,ik,jk) result(val)
class(SELLC_${s1}$_type), intent(in) :: self
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k, ik_, jk_, idx
logical :: transpose
! naive implementation
if( (ik<1 .or. ik>self%nrows) .or. (jk<1 .or. jk>self%ncols) ) then
val = ieee_value( 0._${k1}$ , ieee_quiet_nan)
return
end if
ik_ = ik; jk_ = jk
transpose = (self%storage == sparse_lower .and. ik > jk) .or. (self%storage == sparse_upper .and. ik < jk)
if(transpose) then ! allow extraction of symmetric elements
ik_ = jk; jk_ = ik
end if
idx = self%rowptr((ik_ - 1)/self%chunk_size + 1)
do k = 1, self%chunk_size
if ( jk_ == self%col(k,idx) )then
val = self%data(k,idx)
return
endif
end do
val = zero_${s1}$
end function
subroutine add_value_sellc_${s1}$(self,ik,jk,val)
class(SELLC_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val
integer(ilp), intent(in) :: ik, jk
integer(ilp) :: k, idx
! naive implementation
idx = self%rowptr((ik - 1)/self%chunk_size + 1)
do k = 1, self%chunk_size
if ( jk == self%col(k,idx) )then
self%data(k,idx) = self%data(k,idx) + val
return
endif
end do
end subroutine
subroutine add_block_sellc_${s1}$(self,ik,jk,val)
class(SELLC_${s1}$_type), intent(inout) :: self
${t1}$, intent(in) :: val(:,:)
integer(ilp), intent(in) :: ik(:), jk(:)
integer(ilp) :: k, i, j, idx
! naive implementation
do k = 1 , self%chunk_size
do j = 1, size(jk)
do i = 1, size(ik)
idx = self%rowptr((ik(i) - 1)/self%chunk_size + 1)
if( jk(j) == self%col(k,idx) ) then
self%data(k,idx) = self%data(k,idx) + val(i,j)
end if
end do
end do
end do
end subroutine
#:endfor
end module stdlib_sparse_kinds
fortran-lang-stdlib-0ede301/src/sparse/stdlib_sparse_constants.fypp 0000664 0001750 0001750 00000001755 15135654166 026114 0 ustar alastair alastair #:include "common.fypp"
#:set R_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES, REAL_SUFFIX))
#:set C_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES, CMPLX_SUFFIX))
module stdlib_sparse_constants
use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
use stdlib_constants
implicit none
public
enum, bind(C)
enumerator :: sparse_full !! Full Sparse matrix (no symmetry considerations)
enumerator :: sparse_lower !! Symmetric Sparse matrix with triangular inferior storage
enumerator :: sparse_upper !! Symmetric Sparse matrix with triangular supperior storage
end enum
character(1), parameter :: sparse_op_none = 'N' !! no transpose
character(1), parameter :: sparse_op_transpose = 'T' !! transpose
character(1), parameter :: sparse_op_hermitian = 'H' !! conjugate or hermitian transpose
! Integer size support for ILP64 builds should be done here
integer, parameter :: ilp = int32
end module stdlib_sparse_constants
fortran-lang-stdlib-0ede301/src/system/ 0000775 0001750 0001750 00000000000 15135654166 020301 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/system/stdlib_system_path.f90 0000664 0001750 0001750 00000011650 15135654166 024525 0 ustar alastair alastair submodule(stdlib_system) stdlib_system_path
use stdlib_ascii, only: reverse
use stdlib_strings, only: chomp, join
use stdlib_string_type, only: string_type, char, move
contains
module function join2_char_char(p1, p2) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p1, p2
path = trim(p1) // path_sep() // trim(p2)
end function join2_char_char
module function join2_char_string(p1, p2) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p1
type(string_type), intent(in) :: p2
path = join_path(p1, char(p2))
end function join2_char_string
module function join2_string_char(p1, p2) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p1
character(*), intent(in) :: p2
character(:), allocatable :: join_char
join_char = join_path(char(p1), p2)
call move(join_char, path)
end function join2_string_char
module function join2_string_string(p1, p2) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p1, p2
character(:), allocatable :: join_char
join_char = join_path(char(p1), char(p2))
call move(join_char, path)
end function join2_string_string
module function joinarr_char(p) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p(:)
path = join(p, path_sep())
end function joinarr_char
module function joinarr_string(p) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p(:)
path = join(p, path_sep())
end function joinarr_string
module function join_op_char_char(p1, p2) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p1, p2
path = join_path(p1, p2)
end function join_op_char_char
module function join_op_char_string(p1, p2) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p1
type(string_type), intent(in) :: p2
path = join_path(p1, p2)
end function join_op_char_string
module function join_op_string_char(p1, p2) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p1
character(*), intent(in) :: p2
path = join_path(p1, p2)
end function join_op_string_char
module function join_op_string_string(p1, p2) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p1, p2
path = join_path(p1, p2)
end function join_op_string_string
module subroutine split_path_char(p, head, tail)
character(*), intent(in) :: p
character(:), allocatable, intent(out) :: head, tail
character(:), allocatable :: temp
integer :: i
character(len=1) :: sep
sep = path_sep()
! Empty string, return (.,'')
if (trim(p) == '') then
head = '.'
tail = ''
return
end if
! Remove trailing path separators
temp = trim(chomp(trim(p), sep))
if (temp == '') then
head = sep
tail = ''
return
end if
i = find(reverse(temp), sep)
! if no `pathsep`, then it probably was a root dir like `C:\`
if (i == 0) then
head = temp // sep
tail = ''
return
end if
head = temp(:len(temp)-i)
! child of a root directory
if (find(head, sep) == 0) then
head = head // sep
end if
tail = temp(len(temp)-i+2:)
end subroutine split_path_char
module subroutine split_path_string(p, head, tail)
type(string_type), intent(in) :: p
type(string_type), intent(out) :: head, tail
character(:), allocatable :: head_char, tail_char
call split_path(char(p), head_char, tail_char)
call move(head_char, head)
call move(tail_char, tail)
end subroutine split_path_string
module function base_name_char(p) result(base)
character(:), allocatable :: base, temp
character(*), intent(in) :: p
call split_path(p, temp, base)
end function base_name_char
module function base_name_string(p) result(base)
type(string_type) :: base
type(string_type), intent(in) :: p
type(string_type) :: temp
call split_path(p, temp, base)
end function base_name_string
module function dir_name_char(p) result(dir)
character(:), allocatable :: dir, temp
character(*), intent(in) :: p
call split_path(p, dir, temp)
end function dir_name_char
module function dir_name_string(p) result(dir)
type(string_type) :: dir
type(string_type), intent(in) :: p
type(string_type) :: temp
call split_path(p, dir, temp)
end function dir_name_string
end submodule stdlib_system_path
fortran-lang-stdlib-0ede301/src/system/stdlib_system_subprocess.F90 0000664 0001750 0001750 00000071037 15135654166 025726 0 ustar alastair alastair submodule (stdlib_system) stdlib_system_subprocess
use iso_c_binding
use iso_fortran_env, only: int64, real64
use stdlib_strings, only: join
use stdlib_linalg_state, only: linalg_state_type, LINALG_ERROR, linalg_error_handling
implicit none(type, external)
! Number of CPU ticks between status updates
integer(TICKS), parameter :: CHECK_EVERY_TICKS = 100
! Interface to C support functions from stdlib_system_subprocess.c
interface
! C wrapper to query process status
subroutine process_query_status(pid, wait, is_running, exit_code) &
bind(C, name='process_query_status')
import c_int, c_bool, process_ID
implicit none
! Process ID
integer(process_ID), value :: pid
! Whether to wait for process completion
logical(c_bool), value :: wait
! Whether the process is still running
logical(c_bool), intent(out) :: is_running
! Process exit code (or error code)
integer(c_int), intent(out) :: exit_code
end subroutine process_query_status
subroutine process_create(cmd, stdin_stream, stdin_file, stdout_file, stderr_file, pid) &
bind(C, name='process_create')
import c_char, process_ID
implicit none
character(c_char), intent(in) :: cmd(*)
character(c_char), intent(in), optional :: stdin_stream(*)
character(c_char), intent(in), optional :: stdin_file(*)
character(c_char), intent(in), optional :: stdout_file(*)
character(c_char), intent(in), optional :: stderr_file(*)
integer(process_ID), intent(out) :: pid
end subroutine process_create
logical(c_bool) function process_system_kill(pid) bind(C, name='process_kill')
import c_bool, process_ID
implicit none
integer(process_ID), intent(in), value :: pid
end function process_system_kill
! System implementation of a wait function
subroutine process_wait(seconds) bind(C,name='process_wait')
import c_float
implicit none
real(c_float), intent(in), value :: seconds
end subroutine process_wait
! Utility: check if _WIN32 is defined in the C compiler
logical(c_bool) function process_is_windows() bind(C,name='process_is_windows')
import c_bool
implicit none
end function process_is_windows
end interface
! C boolean constants
logical(c_bool), parameter :: C_FALSE = .false._c_bool
logical(c_bool), parameter :: C_TRUE = .true._c_bool
contains
! Call system-dependent wait implementation
module subroutine sleep(millisec)
integer, intent(in) :: millisec
real(c_float) :: seconds
seconds = 0.001_c_float*max(0,millisec)
call process_wait(seconds)
end subroutine sleep
module function run_async_cmd(cmd, stdin, want_stdout, want_stderr, callback, payload) result(process)
!> The command line string to execute.
character(*), intent(in) :: cmd
!> Optional input sent to the process via standard input (stdin).
character(*), optional, intent(in) :: stdin
!> Whether to collect standard output.
logical, optional, intent(in) :: want_stdout
!> Whether to collect standard error output.
logical, optional, intent(in) :: want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler.
type(process_type) :: process
process = process_open([cmd],.false.,stdin,want_stdout,want_stderr,callback,payload)
end function run_async_cmd
module function run_async_args(args, stdin, want_stdout, want_stderr, callback, payload) result(process)
!> List of arguments for the process to execute.
character(*), intent(in) :: args(:)
!> Optional input sent to the process via standard input (stdin).
character(*), optional, intent(in) :: stdin
!> Whether to collect standard output.
logical, optional, intent(in) :: want_stdout
!> Whether to collect standard error output.
logical, optional, intent(in) :: want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler.
type(process_type) :: process
process = process_open(args,.false.,stdin,want_stdout,want_stderr,callback,payload)
end function run_async_args
module function run_sync_cmd(cmd, stdin, want_stdout, want_stderr, callback, payload) result(process)
!> The command line string to execute.
character(*), intent(in) :: cmd
!> Optional input sent to the process via standard input (stdin).
character(*), optional, intent(in) :: stdin
!> Whether to collect standard output.
logical, optional, intent(in) :: want_stdout
!> Whether to collect standard error output.
logical, optional, intent(in) :: want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler.
type(process_type) :: process
process = process_open([cmd],.true.,stdin,want_stdout,want_stderr,callback,payload)
end function run_sync_cmd
module function run_sync_args(args, stdin, want_stdout, want_stderr, callback, payload) result(process)
!> List of arguments for the process to execute.
character(*), intent(in) :: args(:)
!> Optional input sent to the process via standard input (stdin).
character(*), optional, intent(in) :: stdin
!> Whether to collect standard output.
logical, optional, intent(in) :: want_stdout
!> Whether to collect standard error output.
logical, optional, intent(in) :: want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler.
type(process_type) :: process
process = process_open(args,.true.,stdin,want_stdout,want_stderr,callback,payload)
end function run_sync_args
!> Internal function: open a new process from a command line
function process_open_cmd(cmd,wait,stdin,want_stdout,want_stderr,callback,payload) result(process)
!> The command and arguments
character(*), intent(in) :: cmd
!> Optional character input to be sent to the process via pipe
character(*), optional, intent(in) :: stdin
!> Define if the process should be synchronous (wait=.true.), or asynchronous(wait=.false.)
logical, intent(in) :: wait
!> Require collecting output
logical, optional, intent(in) :: want_stdout, want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler
type(process_type) :: process
process = process_open([cmd],wait,stdin,want_stdout,want_stderr,callback,payload)
end function process_open_cmd
!> Internal function: open a new process from arguments
function process_open(args,wait,stdin,want_stdout,want_stderr,callback,payload) result(process)
!> The command and arguments
character(*), intent(in) :: args(:)
!> Optional character input to be sent to the process via pipe
character(*), optional, intent(in) :: stdin
!> Define if the process should be synchronous (wait=.true.), or asynchronous(wait=.false.)
logical, intent(in) :: wait
!> Require collecting output
logical, optional, intent(in) :: want_stdout, want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler
type(process_type) :: process
real(RTICKS) :: count_rate
logical :: asynchronous, collect_stdout, collect_stderr, has_stdin
integer :: command_state, exit_state
integer(TICKS) :: count_max
! Process user requests
asynchronous = .not.wait
collect_stdout = .false.
collect_stderr = .false.
has_stdin = present(stdin)
if (present(want_stdout)) collect_stdout = want_stdout
if (present(want_stderr)) collect_stderr = want_stderr
! Attach stdout to a scratch file (must be named)
if (has_stdin) process%stdin_file = scratch_name('inp')
if (collect_stdout) process%stdout_file = scratch_name('out')
if (collect_stderr) process%stderr_file = scratch_name('err')
! Attach callback function and payload
if (present(callback)) then
process%oncomplete => callback
else
nullify(process%oncomplete)
end if
if (present(payload)) then
process%payload => payload
else
nullify(process%payload)
end if
! Save the process's generation time
call system_clock(process%start_time,count_rate,count_max)
process%last_update = process%start_time
if (asynchronous) then
! Create or fork a new process, store pid
call launch_asynchronous(process, args, stdin)
else
! No need to create an external process
process%id = FORKED_PROCESS
endif
if (process%id == FORKED_PROCESS) then
! Launch to completion from the local process
call launch_synchronous(process, args, stdin)
call save_completed_state(process,delete_files=.not.asynchronous)
! If the process was forked
! Note: use `exit` rather than `stop` to prevent the mandatory stdout STOP message
if (asynchronous) then
if (command_state/=0) then
! Invalid command: didn't even start
call exit(command_state)
else
! Return exit state
call exit(exit_state)
end if
endif
endif
! Run a first update
call update_process_state(process)
end function process_open
subroutine launch_asynchronous(process, args, stdin)
class(process_type), intent(inout) :: process
!> The command and arguments
character(*), intent(in) :: args(:)
!> Optional character input to be sent to the process via pipe
character(*), optional, intent(in) :: stdin
character(c_char), dimension(:), allocatable, target :: c_cmd,c_stdin,c_stdin_file,c_stdout_file,c_stderr_file
! Assemble C strings
c_cmd = to_c_char(join(args))
if (present(stdin)) c_stdin = to_c_char(stdin)
if (allocated(process%stdin_file)) c_stdin_file = to_c_char(process%stdin_file)
if (allocated(process%stdout_file)) c_stdout_file = to_c_char(process%stdout_file)
if (allocated(process%stderr_file)) c_stderr_file = to_c_char(process%stderr_file)
! On Windows, this 1) creates 2) launches an external process from C.
! On unix, this 1) forks an external process
call process_create(c_cmd, c_stdin, c_stdin_file, c_stdout_file, c_stderr_file, process%id)
end subroutine launch_asynchronous
subroutine launch_synchronous(process, args, stdin)
class(process_type), intent(inout) :: process
!> The command and arguments
character(*), intent(in) :: args(:)
!> Optional character input to be sent to the process via pipe
character(*), optional, intent(in) :: stdin
character(:), allocatable :: cmd
character(4096) :: iomsg
integer :: iostat,estat,cstat,stdin_unit
logical :: has_stdin
has_stdin = present(stdin)
! Prepare stdin
if (has_stdin) then
open(newunit=stdin_unit,file=process%stdin_file, &
access='stream',action='write',position='rewind', &
iostat=iostat,iomsg=iomsg)
if (iostat/=0) error stop 'cannot open temporary stdin'
write(stdin_unit,iostat=iostat,iomsg=iomsg) stdin
if (iostat/=0) error stop trim(iomsg)
close(stdin_unit,iostat=iostat,iomsg=iomsg,status='keep')
if (iostat/=0) error stop 'cannot close temporary stdin'
end if
! Run command
cmd = assemble_cmd(args,process%stdin_file,process%stdout_file,process%stderr_file)
! Execute command
call execute_command_line(cmd,wait=.true.,exitstat=estat,cmdstat=cstat)
! Save state and output
process%exit_code = merge(cstat,estat,cstat/=0)
end subroutine launch_synchronous
!> Return the current (or total) process lifetime, in seconds
real(RTICKS) module function process_lifetime(process) result(delta_t)
class(process_type), intent(in) :: process
real(RTICKS) :: ticks_per_second
integer(TICKS) :: current_time,count_max
! Get current time
call system_clock(current_time,ticks_per_second,count_max)
if (process%completed) then
delta_t = real(process%last_update-process%start_time,RTICKS)/ticks_per_second
else
delta_t = real(current_time-process%start_time,RTICKS)/ticks_per_second
end if
end function process_lifetime
!> Wait for a process to be completed
module subroutine wait_for_completion(process, max_wait_time)
class(process_type), intent(inout) :: process
! Optional max wait time in seconds
real, optional, intent(in) :: max_wait_time
integer :: sleep_interval
real(RTICKS) :: wait_time, elapsed
integer(TICKS) :: start_time, current_time, count_rate
! Sleep interval ms
integer, parameter :: MIN_WAIT_MS = 1
integer, parameter :: MAX_WAIT_MS = 100
! Starting sleep interval: 1ms
sleep_interval = MIN_WAIT_MS
! Determine the wait time
if (present(max_wait_time)) then
wait_time = max(0.0_RTICKS, max_wait_time)
else
! No limit if max_wait_time is not provided
wait_time = huge(wait_time)
end if
! Get the system clock rate and the start time
call system_clock(start_time, count_rate)
elapsed = 0.0_real64
! Wait loop
wait_loop: do while (process_is_running(process) .and. elapsed <= wait_time)
! Small sleep to avoid CPU hogging, with exponential backoff (1 ms)
! from 1ms up to 100ms
call sleep(millisec=sleep_interval)
sleep_interval = min(sleep_interval*2, MAX_WAIT_MS)
call system_clock(current_time)
elapsed = real(current_time - start_time, RTICKS) / count_rate
end do wait_loop
end subroutine wait_for_completion
!> Update a process's state, and save it to the process variable
module subroutine update_process_state(process)
class(process_type), intent(inout) :: process
real(RTICKS) :: count_rate
integer(TICKS) :: count_max,current_time
logical(c_bool) :: running
integer(c_int) :: exit_code
! If the process has completed, should not be queried again
if (process%completed) return
! Save the process's generation time
call system_clock(current_time,count_rate,count_max)
! Only trigger an update after at least 100 count units
if (abs(real(current_time-process%last_update,RTICKS)) Live check if a process is running
logical module function process_is_running(process) result(is_running)
class(process_type), intent(inout) :: process
! Each evaluation triggers a state update
call update_process_state(process)
is_running = .not.process%completed
end function process_is_running
!> Live check if a process has completed
logical module function process_is_completed(process) result(is_completed)
class(process_type), intent(inout) :: process
! Each evaluation triggers a state update
call update_process_state(process)
is_completed = process%completed
end function process_is_completed
function scratch_name(prefix) result(temp_filename)
character(*), optional, intent(in) :: prefix
character(:), allocatable :: temp_filename
character(len=8) :: date
character(len=10) :: time
character(len=7) :: rand_str
real :: rrand
integer :: rand_val
! Get the current date and time
call date_and_time(date=date, time=time)
! Generate a random number for additional uniqueness
call random_number(rrand)
rand_val = nint(rrand * 1e6) ! Scale random number
write(rand_str,'(i7.7)') rand_val
! Construct the filename
if (present(prefix)) then
temp_filename = trim(prefix)// '_' // date // '_' // time(1:6) // '_' // rand_str // '.tmp'
else
temp_filename = 'tmp_' // date // '_' // time(1:6) // '_' // rand_str // '.tmp'
endif
end function scratch_name
!> Assemble a single-line proces command line from a list of arguments.
!>
!> Version: Helper function.
function assemble_cmd(args, stdin, stdout, stderr) result(cmd)
!> Command to execute as a string
character(len=*), intent(in) :: args(:)
!> [optional] File name standard input (stdin) should be taken from
character(len=*), optional, intent(in) :: stdin
!> [optional] File name standard output (stdout) should be directed to
character(len=*), optional, intent(in) :: stdout
!> [optional] File name error output (stderr) should be directed to
character(len=*), optional, intent(in) :: stderr
character(:), allocatable :: cmd,stdout_file,input_file,stderr_file
if (present(stdin)) then
input_file = stdin
else
input_file = null_device()
end if
if (present(stdout)) then
! Redirect output to a file
stdout_file = stdout
else
stdout_file = null_device()
endif
if (present(stderr)) then
stderr_file = stderr
else
stderr_file = null_device()
end if
cmd = join(args)//" <"//input_file//" 1>"//stdout_file//" 2>"//stderr_file
end function assemble_cmd
!> Returns the file path of the null device for the current operating system.
!>
!> Version: Helper function.
logical module function is_windows()
is_windows = logical(process_is_windows())
end function is_windows
!> Reads a whole ASCII file and loads its contents into an allocatable character string..
!> The function handles error states and optionally deletes the file after reading.
!> Temporarily uses `linalg_state_type` in lieu of the generalized `state_type`.
!>
!> Version: to be replaced after `getfile` is standardized in `stdlib_io`.
function getfile(fileName,err,delete) result(file)
!> Input file name
character(*), intent(in) :: fileName
!> [optional] State return flag. On error, if not requested, the code will stop.
type(linalg_state_type), optional, intent(out) :: err
!> [optional] Delete file after reading? Default: do not delete
logical, optional, intent(in) :: delete
!> Return as an allocatable string
character(:), allocatable :: file
! Local variables
character(*), parameter :: CRLF = achar(13)//new_line('a')
type(linalg_state_type) :: err0
character(len=:), allocatable :: fileString
character(len=512) :: iomsg
character :: last_char
integer :: lun,iostat
integer(int64) :: errpos,fileSize
logical :: is_present,want_deleted
! Initializations
file = ""
!> Check if the file should be deleted after reading
if (present(delete)) then
want_deleted = delete
else
want_deleted = .false.
end if
!> Check file existing
inquire(file=fileName, exist=is_present)
if (.not.is_present) then
err0 = linalg_state_type('getfile',LINALG_ERROR,'File not present:',fileName)
call linalg_error_handling(err0,err)
return
end if
!> Retrieve file size
inquire(file=fileName,size=fileSize)
invalid_size: if (fileSize<0) then
err0 = linalg_state_type('getfile',LINALG_ERROR,fileName,'has invalid size=',fileSize)
call linalg_error_handling(err0,err)
return
endif invalid_size
! Read file
open(newunit=lun,file=fileName, &
form='unformatted',action='read',access='stream',status='old', &
iostat=iostat,iomsg=iomsg)
if (iostat/=0) then
err0 = linalg_state_type('getfile',LINALG_ERROR,'Cannot open',fileName,'for read:',iomsg)
call linalg_error_handling(err0,err)
return
end if
remove_trailing_newline: if (fileSize>0) then
last_char = CRLF(1:1)
fileSize = fileSize+1
do while (scan(last_char,CRLF)>0 .and. fileSize>1)
fileSize = fileSize-1
read(lun, pos=fileSize, iostat=iostat, iomsg=iomsg) last_char
! Read error
if (iostat/=0) then
err0 = linalg_state_type('getfile',LINALG_ERROR,iomsg,'(',fileName,'at byte',fileSize,')')
call linalg_error_handling(err0,err)
return
endif
end do
endif remove_trailing_newline
allocate(character(len=fileSize) :: fileString)
read_data: if (fileSize>0) then
read(lun, pos=1, iostat=iostat, iomsg=iomsg) fileString
! Read error
if (iostat/=0) then
inquire(unit=lun,pos=errpos)
err0 = linalg_state_type('getfile',LINALG_ERROR,iomsg,'(',fileName,'at byte',errpos,')')
call linalg_error_handling(err0,err)
return
endif
end if read_data
if (want_deleted) then
close(lun,iostat=iostat,status='delete')
if (iostat/=0) err0 = linalg_state_type('getfile',LINALG_ERROR,'Cannot delete',fileName,'after reading')
else
close(lun,iostat=iostat)
if (iostat/=0) err0 = linalg_state_type('getfile',LINALG_ERROR,'Cannot close',fileName,'after reading')
endif
! Process output
call move_alloc(from=fileString,to=file)
call linalg_error_handling(err0,err)
end function getfile
!> Return process ID
module function process_get_ID(process) result(ID)
class(process_type), intent(in) :: process
!> Return a process ID
integer(process_ID) :: ID
ID = process%id
end function process_get_ID
end submodule stdlib_system_subprocess
fortran-lang-stdlib-0ede301/src/system/stdlib_system.F90 0000664 0001750 0001750 00000136167 15135654166 023464 0 ustar alastair alastair module stdlib_system
use, intrinsic :: iso_c_binding, only : c_int, c_long, c_ptr, c_null_ptr, c_int64_t, c_size_t, &
c_f_pointer
use stdlib_kinds, only: int64, dp, c_bool, c_char
use stdlib_strings, only: to_c_char, find, to_string
use stdlib_string_type, only: string_type
use stdlib_optval, only: optval
use stdlib_error, only: state_type, STDLIB_SUCCESS, STDLIB_FS_ERROR
implicit none
private
public :: sleep
!! version: experimental
!!
!! Cached OS type retrieval with negligible runtime overhead.
!! ([Specification](../page/specs/stdlib_system.html#os_type-cached-os-type-retrieval))
!!
!! ### Summary
!! Provides a cached value for the runtime OS type.
!!
!! ### Description
!!
!! This function caches the result of `get_runtime_os` after the first invocation.
!! Subsequent calls return the cached value, ensuring minimal overhead.
!!
public :: OS_TYPE
!! version: experimental
!!
!! Determine the current operating system (OS) type at runtime.
!! ([Specification](../page/specs/stdlib_system.html#get_runtime_os-determine-the-os-type-at-runtime))
!!
!! ### Summary
!! This function inspects the runtime environment to identify the OS type.
!!
!! ### Description
!!
!! The function evaluates environment variables (`OSTYPE` or `OS`) and filesystem attributes
!! to identify the OS. It distinguishes between several common operating systems:
!! - Linux
!! - macOS
!! - Windows
!! - Cygwin
!! - Solaris
!! - FreeBSD
!! - OpenBSD
!!
!! Returns a constant representing the OS type or `OS_UNKNOWN` if the OS cannot be determined.
!!
public :: get_runtime_os
!> Version: experimental
!>
!> Integer constants representing known operating system (OS) types
!> ([Specification](../page/specs/stdlib_system.html))
integer, parameter, public :: &
!> Represents an unknown operating system
OS_UNKNOWN = 0, &
!> Represents a Linux operating system
OS_LINUX = 1, &
!> Represents a macOS operating system
OS_MACOS = 2, &
!> Represents a Windows operating system
OS_WINDOWS = 3, &
!> Represents a Cygwin environment
OS_CYGWIN = 4, &
!> Represents a Solaris operating system
OS_SOLARIS = 5, &
!> Represents a FreeBSD operating system
OS_FREEBSD = 6, &
!> Represents an OpenBSD operating system
OS_OPENBSD = 7
!! Helper function returning the name of an OS parameter
public :: OS_NAME
!> Public sub-processing interface
public :: run
public :: runasync
public :: process_type
public :: is_completed
public :: is_running
public :: update
public :: wait
public :: kill
public :: elapsed
public :: is_windows
!! Public path related functions and interfaces
public :: path_sep
public :: join_path
public :: operator(/)
public :: split_path
public :: base_name
public :: dir_name
!! version: experimental
!!
!! Tests if a given path matches an existing directory.
!! ([Specification](../page/specs/stdlib_system.html#is_directory-test-if-a-path-is-a-directory))
!!
!!### Summary
!! Function to evaluate whether a specified path corresponds to an existing directory.
!!
!!### Description
!!
!! This function checks if a given file system path is a directory.
!! It follows symbolic links to return the status of the `target`.
!!
!! It is cross-platform and utilizes native system calls.
!! It supports common operating systems such as Linux, macOS, Windows, and various UNIX-like environments.
!! On unsupported operating systems, the function will return `.false.`.
!!
public :: is_directory
!! version: experimental
!!
!! Makes an empty directory.
!! ([Specification](../page/specs/stdlib_system.html#make_directory))
!!
!! ### Summary
!! Creates an empty directory with default permissions.
!!
!! ### Description
!! This function makes an empty directory according to the path provided.
!! Relative paths are supported. On Windows, paths involving either `/` or `\` are accepted.
!! An appropriate error message is returned whenever any error occurs.
!!
public :: make_directory
!! version: experimental
!!
!! Makes an empty directory, also creating all the parent directories required.
!! ([Specification](../page/specs/stdlib_system.html#make_directory))
!!
!! ### Summary
!! Creates an empty directory with all the parent directories required to do so.
!!
!! ### Description
!! This function makes an empty directory according to the path provided.
!! It also creates all the necessary parent directories in the path if they do not exist already.
!! Relative paths are supported.
!! An appropriate error message is returned whenever any error occurs.
!!
public :: make_directory_all
!! version: experimental
!!
!! Removes an empty directory.
!! ([Specification](../page/specs/stdlib_system.html#remove_directory))
!!
!! ### Summary
!! Removes an empty directory.
!!
!! ### Description
!! This function Removes an empty directory according to the path provided.
!! Relative paths are supported. On Windows paths involving either `/` or `\` are accepted.
!! An appropriate error message is returned whenever any error occurs.
!!
public :: remove_directory
!! version: experimental
!!
!! Gets the current working directory of the process
!! ([Specification](../page/specs/stdlib_system.html#get_cwd))
!!
!! ### Summary
!! Gets the current working directory.
!!
!! ### Description
!! This subroutine gets the current working directory the process is executing from.
!!
public :: get_cwd
!! version: experimental
!!
!! Sets the current working directory of the process
!! ([Specification](../page/specs/stdlib_system.html#set_cwd))
!!
!! ### Summary
!! Changes the current working directory to the one specified.
!!
!! ### Description
!! This subroutine sets the current working directory the process is executing from.
!!
public :: set_cwd
!! version: experimental
!!
!! Deletes a specified file from the filesystem.
!! ([Specification](../page/specs/stdlib_system.html#delete_file-delete-a-file))
!!
!!### Summary
!! Subroutine to safely delete a file from the filesystem. It handles errors gracefully using the library's `state_type`.
!!
!!### Description
!!
!! This subroutine deletes a specified file. If the file is a directory or inaccessible, an error is raised.
!! If the file does not exist, a warning is returned, but no error state. Errors are handled using the
!! library's `state_type` mechanism. If the optional `err` argument is not provided, exceptions trigger
!! an `error stop`.
!!
public :: delete_file
!! version: experimental
!!
!! Returns the file path of the null device, which discards all data written to it.
!! ([Specification](../page/specs/stdlib_system.html#null_device-return-the-null-device-file-path))
!!
!! ### Summary
!! Function that provides the file path of the null device appropriate for the current operating system.
!!
!! ### Description
!!
!! The null device is a special file that discards all data written to it and always reads as
!! an empty file. This function returns the null device path, adapted for the operating system in use.
!!
!! On Windows, this is `NUL`. On UNIX-like systems, this is `/dev/null`.
!!
public :: null_device
!! version: experimental
!!
!! A helper function for returning the `type(state_type)` with the flag `STDLIB_FS_ERROR` set.
!! ([Specification](../page/specs/stdlib_system.html#FS_ERROR))
!!
public :: FS_ERROR
!! version: experimental
!!
!! A helper function for returning the `type(state_type)` with the flag `STDLIB_FS_ERROR` set.
!! It also formats and prefixes the `code` passed to it as the first argument
!! ([Specification](../page/specs/stdlib_system.html#FS_ERROR_CODE))
!!
public :: FS_ERROR_CODE
!> Version: experimental
!>
!> Integer constants representing the most common path types.
!> ([Specification](../page/specs/stdlib_system.html))
integer, parameter, public :: &
!> Represents an unknown path type
fs_type_unknown = 0, &
!> Represents a regular file
fs_type_regular_file = 1, &
!> Represents a directory
fs_type_directory = 2, &
!> Represents a symbolic link
fs_type_symlink = 3
!! version: experimental
!!
!! Checks if a path exists in the filesystem.
!! ([Specification](../page/specs/stdlib_system.html#exists))
!!
!!### Summary
!! Function to check whether the path exists in the fileystem at all.
!! If the path does exist, returns the type of the path.
!!
!!### Description
!!
!! This function makes a system call (syscall) to retrieve metadata for the specified path and determines its type.
!! It can distinguish between the following path types:
!!
!! - Regular File
!! - Directory
!! - Symbolic Link
!!
!! It does not follow symbolic links.
!!
!! It returns a constant representing the detected path type, or `type_unknown` if the type cannot be determined.
!! Any encountered errors are handled using `state_type`.
!!
public :: exists
!! version: experimental
!!
!! Tests if a given path is a symbolic link.
!! ([Specification](../page/specs/stdlib_system.html#is_symlink))
!!
!!### Summary
!! Function to evaluate whether a specified path corresponds to a symbolic link.
!!
!!### Description
!!
!! This function checks if a given file system path is a symbolic link either to a
!! file or a directory. It is cross-platform and utilizes native system calls.
!! It supports common operating systems such as Linux, macOS, Windows, and various UNIX-like environments.
!!
public :: is_symlink
!! version: experimental
!!
!! Tests if a given path is a regular file.
!! ([Specification](../page/specs/stdlib_system.html#is_file))
!!
!!### Summary
!! Function to evaluate whether a specified path corresponds to a regular file.
!!
!!### Description
!!
!! This function checks if a given file system path is a regular file.
!! It follows symbolic links to return the status of the `target`.
!! It is cross-platform and utilizes native system calls.
!! It supports common operating systems such as Linux, macOS, Windows, and various UNIX-like environments.
!!
public :: is_file
! CPU clock ticks storage
integer, parameter, private :: TICKS = int64
integer, parameter, private :: RTICKS = dp
! Interoperable types to the C backend
integer, parameter, public :: process_ID = c_int64_t
! Default flag for the runner process
integer(process_ID), parameter, private :: FORKED_PROCESS = 0_process_ID
!> Process type holding process information and the connected stdout, stderr, stdin units
type :: process_type
!> Process ID (if external); 0 if run by the program process
integer(process_ID) :: id = FORKED_PROCESS
!> Process is completed
logical :: completed = .false.
integer(TICKS) :: start_time = 0
!> Standard input
character(:), allocatable :: stdin_file
character(:), allocatable :: stdin
!> Standard output
character(:), allocatable :: stdout_file
character(:), allocatable :: stdout
!> Error output
integer :: exit_code = 0
character(:), allocatable :: stderr_file
character(:), allocatable :: stderr
!> Callback function
procedure(process_callback), nopass, pointer :: oncomplete => null()
!> Optional payload for the callback function
class(*), pointer :: payload => null()
!> Store time at the last update
integer(TICKS) :: last_update = 0
contains
!! Check if process is still running
procedure :: is_running => process_is_running
!! Check if process is completed
procedure :: is_completed => process_is_completed
!! Return elapsed time since inception
procedure :: elapsed => process_lifetime
!! Update process state internals
procedure :: update => update_process_state
!! Kill a process
procedure :: kill => process_kill
!! Get process ID
procedure :: pid => process_get_ID
end type process_type
interface runasync
!! version: experimental
!!
!! Executes an external process asynchronously.
!! ([Specification](../page/specs/stdlib_system.html#runasync-execute-an-external-process-asynchronously))
!!
!! ### Summary
!! Provides methods for executing external processes asynchronously, using either a single command string
!! or an argument list, with options for output collection and standard input.
!!
!! ### Description
!!
!! This interface allows the user to spawn external processes asynchronously (non-blocking).
!! Processes can be executed via a single command string or a list of arguments, with options to collect
!! standard output and error streams, or to provide a standard input stream via a `character` string.
!! Additionally, a callback function can be provided, which will be called upon process completion.
!! A user-defined payload can be attached and passed to the callback for handling process-specific data.
!!
!! @note The implementation depends on system-level process management capabilities.
!!
module function run_async_cmd(cmd, stdin, want_stdout, want_stderr, callback, payload) result(process)
!> The command line string to execute.
character(*), intent(in) :: cmd
!> Optional input sent to the process via standard input (stdin).
character(*), optional, intent(in) :: stdin
!> Whether to collect standard output.
logical, optional, intent(in) :: want_stdout
!> Whether to collect standard error output.
logical, optional, intent(in) :: want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler.
type(process_type) :: process
end function run_async_cmd
module function run_async_args(args, stdin, want_stdout, want_stderr, callback, payload) result(process)
!> List of arguments for the process to execute.
character(*), intent(in) :: args(:)
!> Optional input sent to the process via standard input (stdin).
character(*), optional, intent(in) :: stdin
!> Whether to collect standard output.
logical, optional, intent(in) :: want_stdout
!> Whether to collect standard error output.
logical, optional, intent(in) :: want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler.
type(process_type) :: process
end function run_async_args
end interface runasync
interface run
!! version: experimental
!!
!! Executes an external process synchronously.
!! ([Specification](../page/specs/stdlib_system.html#run-execute-an-external-process-synchronously))
!!
!! ### Summary
!! Provides methods for executing external processes synchronously, using either a single command string
!! or an argument list, with options for output collection and standard input.
!!
!! ### Description
!!
!! This interface allows the user to spawn external processes synchronously (blocking),
!! via either a single command string or a list of arguments. It also includes options to collect
!! standard output and error streams, or to provide a standard input stream via a `character` string.
!! Additionally, it supports an optional callback function that is invoked upon process completion,
!! allowing users to process results dynamically. A user-defined payload can also be provided,
!! which is passed to the callback function to facilitate contextual processing.
!!
!! @note The implementation depends on system-level process management capabilities.
!!
module function run_sync_cmd(cmd, stdin, want_stdout, want_stderr, callback, payload) result(process)
!> The command line string to execute.
character(*), intent(in) :: cmd
!> Optional input sent to the process via standard input (stdin).
character(*), optional, intent(in) :: stdin
!> Whether to collect standard output.
logical, optional, intent(in) :: want_stdout
!> Whether to collect standard error output.
logical, optional, intent(in) :: want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler.
type(process_type) :: process
end function run_sync_cmd
module function run_sync_args(args, stdin, want_stdout, want_stderr, callback, payload) result(process)
!> List of arguments for the process to execute.
character(*), intent(in) :: args(:)
!> Optional input sent to the process via standard input (stdin).
character(*), optional, intent(in) :: stdin
!> Whether to collect standard output.
logical, optional, intent(in) :: want_stdout
!> Whether to collect standard error output.
logical, optional, intent(in) :: want_stderr
!> Optional callback function to be called on process completion
procedure(process_callback), optional :: callback
!> Optional payload to pass to the callback on completion
class(*), optional, intent(inout), target :: payload
!> The output process handler.
type(process_type) :: process
end function run_sync_args
end interface run
interface is_running
!! version: experimental
!!
!! Checks if an external process is still running.
!! ([Specification](../page/specs/stdlib_system.html#is_running-check-if-a-process-is-still-running))
!!
!! ### Summary
!! Provides a method to determine if an external process is still actively running.
!!
!! ### Description
!!
!! This interface checks the status of an external process to determine whether it is still actively running.
!! It is particularly useful for monitoring asynchronous processes created using the `run` interface.
!! The internal state of the `process_type` object is updated after the call to reflect the current process status.
!!
!! @note The implementation relies on system-level process management capabilities.
!!
logical module function process_is_running(process) result(is_running)
!> The process object to check.
class(process_type), intent(inout) :: process
!> Logical result: `.true.` if the process is still running, `.false.` otherwise.
end function process_is_running
end interface is_running
interface is_completed
!! version: experimental
!!
!! Checks if an external process has completed execution.
!! ([Specification](../page/specs/stdlib_system.html#is_completed-check-if-a-process-has-completed-execution))
!!
!! ### Summary
!! Provides a method to determine if an external process has finished execution.
!!
!! ### Description
!!
!! This interface checks the status of an external process to determine whether it has finished execution.
!! It is particularly useful for monitoring asynchronous processes created using the `run` interface.
!! The internal state of the `process_type` object is updated after the call to reflect the current process status.
!!
!! @note The implementation relies on system-level process management capabilities.
!!
logical module function process_is_completed(process) result(is_completed)
!> The process object to check.
class(process_type), intent(inout) :: process
!> Logical result: `.true.` if the process has completed, `.false.` otherwise.
end function process_is_completed
end interface is_completed
interface elapsed
!! version: experimental
!!
!! Returns the lifetime of a process, in seconds.
!! ([Specification](../page/specs/stdlib_system.html#elapsed-return-process-lifetime-in-seconds))
!!
!! ### Summary
!! Provides the total elapsed time (in seconds) since the creation of the specified process.
!!
!! ### Description
!!
!! This interface returns the total elapsed time (in seconds) for a given process since it was started.
!! If the process is still running, the value returned reflects the time from the creation of the process
!! until the call to this function. Otherwise, the total process duration until completion is returned.
!!
module function process_lifetime(process) result(delta_t)
!> The process object for which to calculate elapsed time.
class(process_type), intent(in) :: process
!> The elapsed time in seconds since the process started.
real(RTICKS) :: delta_t
end function process_lifetime
end interface elapsed
interface wait
!! version: experimental
!!
!! Waits for a running process to complete.
!! ([Specification](../page/specs/stdlib_system.html#wait-wait-until-a-running-process-is-completed))
!!
!! ### Summary
!! Provides a method to block the execution and wait until the specified process finishes.
!! Supports an optional maximum wait time, after which the function returns regardless of process completion.
!!
!! ### Description
!!
!! This interface allows waiting for a process to complete. If the process is running asynchronously, this subroutine
!! will block further execution until the process finishes. Optionally, a maximum wait time can be specified; if
!! the process doesn't complete within this time, the subroutine returns without further waiting.
!!
!! @note The process state is accordingly updated on return from this call.
!!
module subroutine wait_for_completion(process, max_wait_time)
!> The process object to monitor.
class(process_type), intent(inout) :: process
!> Optional maximum wait time in seconds. If not provided, waits indefinitely.
real, optional, intent(in) :: max_wait_time
end subroutine wait_for_completion
end interface wait
interface update
!! version: experimental
!!
!! Updates the internal state of a process variable.
!! ([Specification](../page/specs/stdlib_system.html#update-update-the-internal-state-of-a-process))
!!
!! ### Summary
!! Provides a method to query the system and update the internal state of the specified process variable.
!!
!! ### Description
!!
!! This subroutine queries the system to retrieve and update information about the state of the process.
!! Once the process is completed, and if standard output or standard error were requested, their respective
!! data is loaded into the `process%stdout` and `process%stderr` variables. This routine is useful for keeping
!! track of the latest state and output of a process, particularly for asynchronous processes.
!!
!! @note This subroutine should be called periodically for asynchronous processes to check their completion
!! and retrieve the output.
!!
module subroutine update_process_state(process)
!> The process object whose state needs to be updated.
class(process_type), intent(inout) :: process
end subroutine update_process_state
end interface update
interface kill
!! version: experimental
!!
!! Terminates a running process.
!! ([Specification](../page/specs/stdlib_system.html#kill-terminate-a-running-process))
!!
!! ### Summary
!! Provides a method to kill or terminate a running process.
!! Returns a boolean flag indicating whether the termination was successful.
!!
!! ### Description
!!
!! This interface allows for the termination of an external process that is still running.
!! If the process is successfully killed, the `success` output flag is set to `.true.`, otherwise `.false.`.
!! This function is useful for controlling and managing processes that are no longer needed or for forcefully
!! stopping an unresponsive process.
!!
!! @note This operation may be system-dependent and could fail if the underlying user does not have
!! the necessary rights to kill a process.
!!
module subroutine process_kill(process, success)
!> The process object to be terminated.
class(process_type), intent(inout) :: process
!> Boolean flag indicating whether the termination was successful.
logical, intent(out) :: success
end subroutine process_kill
end interface kill
interface sleep
!! version: experimental
!!
!! Pauses execution for a specified time in milliseconds.
!! ([Specification](../page/specs/stdlib_system.html#sleep-pause-execution-for-a-specified-time=in-milliseconds))
!!
!! ### Summary
!! Pauses code execution for a specified number of milliseconds. This routine is a cross-platform
!! wrapper around platform-specific sleep functions, providing consistent behavior on different operating systems.
!!
!! ### Description
!!
!! This interface allows the user to pause the execution of a program for a specified duration, expressed in
!! milliseconds. It provides a cross-platform wrapper around native sleep functions, ensuring that the program
!! will sleep for the requested amount of time on different systems (e.g., using `Sleep` on Windows or `nanosleep`
!! on Unix-like systems).
!!
!! @note The precision of the sleep may vary depending on the system and platform.
!!
module subroutine sleep(millisec)
!> The number of milliseconds to pause execution for.
integer, intent(in) :: millisec
end subroutine sleep
end interface sleep
abstract interface
!! version: experimental
!!
!! Process callback interface
!!
!! ### Summary
!!
!! The `process_callback` interface defines a user-provided subroutine that will be called
!! upon process completion. It provides access to process metadata, including the process ID,
!! exit state, and optional input/output streams. If passed on creation, a generic payload can be
!! accessed by the callback function. This variable must be a valid `target` in the calling scope.
!!
subroutine process_callback(pid,exit_state,stdin,stdout,stderr,payload)
import process_ID
implicit none
!> Process ID
integer(process_ID), intent(in) :: pid
!> Process return state
integer, intent(in) :: exit_state
!> Process input/output: presence of these arguments depends on how process was created
character(len=*), optional, intent(in) :: stdin,stdout,stderr
!> Optional payload passed by the user on process creation
class(*), optional, intent(inout) :: payload
end subroutine process_callback
end interface
!! Static storage for the current OS
logical :: have_os = .false.
integer :: OS_CURRENT = OS_UNKNOWN
interface
!! version: experimental
!!
!! Returns a `logical` flag indicating if the system is Windows.
!! ([Specification](../page/specs/stdlib_system.html#is_windows-check-if-the-system-is-running-on-windows))
!!
!! ### Summary
!! A fast, compile-time check to determine if the system is running Windows, based on the `_WIN32` macro.
!!
!! ### Description
!!
!! This interface provides a function to check if the current system is Windows. The check is performed by
!! wrapping a C function that tests if the `_WIN32` macro is defined. This check is fast and occurs at
!! compile-time, making it a more efficient alternative to platform-specific runtime checks.
!!
!! The `is_windows` function is particularly useful for conditional compilation or system-specific code paths
!! that are dependent on whether the code is running on Windows.
!!
!! @note This function relies on the `_WIN32` macro, which is defined in C compilers when targeting Windows.
!!
logical module function is_windows()
end function is_windows
module function process_get_ID(process) result(ID)
class(process_type), intent(in) :: process
!> Return a process ID
integer(process_ID) :: ID
end function process_get_ID
end interface
interface join_path
!! version: experimental
!!
!!### Summary
!! join the paths provided according to the OS-specific path-separator
!! ([Specification](../page/specs/stdlib_system.html#join_path))
!!
module function join2_char_char(p1, p2) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p1, p2
end function join2_char_char
module function join2_char_string(p1, p2) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p1
type(string_type), intent(in) :: p2
end function join2_char_string
module function join2_string_char(p1, p2) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p1
character(*), intent(in) :: p2
end function join2_string_char
module function join2_string_string(p1, p2) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p1, p2
end function join2_string_string
module function joinarr_char(p) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p(:)
end function joinarr_char
module function joinarr_string(p) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p(:)
end function joinarr_string
end interface join_path
interface operator(/)
!! version: experimental
!!
!!### Summary
!! A binary operator to join the paths provided according to the OS-specific path-separator
!! ([Specification](../page/specs/stdlib_system.html#operator(/)))
!!
module function join_op_char_char(p1, p2) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p1, p2
end function join_op_char_char
module function join_op_char_string(p1, p2) result(path)
character(:), allocatable :: path
character(*), intent(in) :: p1
type(string_type), intent(in) :: p2
end function join_op_char_string
module function join_op_string_char(p1, p2) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p1
character(*), intent(in) :: p2
end function join_op_string_char
module function join_op_string_string(p1, p2) result(path)
type(string_type) :: path
type(string_type), intent(in) :: p1, p2
end function join_op_string_string
end interface operator(/)
interface split_path
!! version: experimental
!!
!!### Summary
!! splits the path immediately following the final path-separator
!! separating into typically a directory and a file name.
!! ([Specification](../page/specs/stdlib_system.html#split_path))
!!
!!### Description
!! If the path is empty `head`='.' and tail=''
!! If the path only consists of separators, `head` is set to the separator and tail is empty
!! If the path is a root directory, `head` is set to that directory and tail is empty
!! `head` ends with a path-separator iff the path appears to be a root directory or a child of the root directory
module subroutine split_path_char(p, head, tail)
character(*), intent(in) :: p
character(:), allocatable, intent(out) :: head, tail
end subroutine split_path_char
module subroutine split_path_string(p, head, tail)
type(string_type), intent(in) :: p
type(string_type), intent(out) :: head, tail
end subroutine split_path_string
end interface split_path
interface base_name
!! version: experimental
!!
!!### Summary
!! returns the base name (last component) of the provided path
!! ([Specification](../page/specs/stdlib_system.html#base_name))
!!
!!### Description
!! The value returned is the `tail` of the interface `split_path`
module function base_name_char(p) result(base)
character(:), allocatable :: base
character(*), intent(in) :: p
end function base_name_char
module function base_name_string(p) result(base)
type(string_type) :: base
type(string_type), intent(in) :: p
end function base_name_string
end interface base_name
interface dir_name
!! version: experimental
!!
!!### Summary
!! returns everything but the last component of the provided path
!! ([Specification](../page/specs/stdlib_system.html#dir_name))
!!
!!### Description
!! The value returned is the `head` of the interface `split_path`
module function dir_name_char(p) result(dir)
character(:), allocatable :: dir
character(*), intent(in) :: p
end function dir_name_char
module function dir_name_string(p) result(dir)
type(string_type) :: dir
type(string_type), intent(in) :: p
end function dir_name_string
end interface dir_name
contains
integer function get_runtime_os() result(os)
!! The function identifies the OS by inspecting environment variables and filesystem attributes.
!!
!! ### Returns:
!! - **OS_UNKNOWN**: If the OS cannot be determined.
!! - **OS_LINUX**, **OS_MACOS**, **OS_WINDOWS**, **OS_CYGWIN**, **OS_SOLARIS**, **OS_FREEBSD**, or **OS_OPENBSD**.
!!
!! Note: This function performs a detailed runtime inspection, so it has non-negligible overhead.
! Local variables
character(len=255) :: val
integer :: length, rc
logical :: file_exists
os = OS_UNKNOWN
! Check environment variable `OSTYPE`.
call get_environment_variable('OSTYPE', val, length, rc)
if (rc == 0 .and. length > 0) then
! Linux
if (index(val, 'linux') > 0) then
os = OS_LINUX
return
! macOS
elseif (index(val, 'darwin') > 0) then
os = OS_MACOS
return
! Windows, MSYS, MinGW, Git Bash
elseif (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then
os = OS_WINDOWS
return
! Cygwin
elseif (index(val, 'cygwin') > 0) then
os = OS_CYGWIN
return
! Solaris, OpenIndiana, ...
elseif (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then
os = OS_SOLARIS
return
! FreeBSD
elseif (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then
os = OS_FREEBSD
return
! OpenBSD
elseif (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then
os = OS_OPENBSD
return
end if
end if
! Check environment variable `OS`.
call get_environment_variable('OS', val, length, rc)
if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then
os = OS_WINDOWS
return
end if
! Linux
inquire (file='/etc/os-release', exist=file_exists)
if (file_exists) then
os = OS_LINUX
return
end if
! macOS
inquire (file='/usr/bin/sw_vers', exist=file_exists)
if (file_exists) then
os = OS_MACOS
return
end if
! FreeBSD
inquire (file='/bin/freebsd-version', exist=file_exists)
if (file_exists) then
os = OS_FREEBSD
return
end if
end function get_runtime_os
!> Retrieves the cached OS type for minimal runtime overhead.
integer function OS_TYPE() result(os)
!! This function uses a static cache to avoid recalculating the OS type after the first call.
!! It is recommended for performance-sensitive use cases where the OS type is checked multiple times.
if (.not.have_os) then
OS_CURRENT = get_runtime_os()
have_os = .true.
end if
os = OS_CURRENT
end function OS_TYPE
!> Return string describing the OS type flag
pure function OS_NAME(os)
integer, intent(in) :: os
character(len=:), allocatable :: OS_NAME
select case (os)
case (OS_LINUX); OS_NAME = "Linux"
case (OS_MACOS); OS_NAME = "macOS"
case (OS_WINDOWS); OS_NAME = "Windows"
case (OS_CYGWIN); OS_NAME = "Cygwin"
case (OS_SOLARIS); OS_NAME = "Solaris"
case (OS_FREEBSD); OS_NAME = "FreeBSD"
case (OS_OPENBSD); OS_NAME = "OpenBSD"
case default ; OS_NAME = "Unknown"
end select
end function OS_NAME
!! Tests if a given path matches an existing directory.
!! Cross-platform implementation without using external C libraries.
logical function is_directory(path)
!> Input path to evaluate
character(*), intent(in) :: path
interface
logical(c_bool) function stdlib_is_directory(path) bind(c, name="stdlib_is_directory")
import c_bool, c_char
character(kind=c_char), intent(in) :: path(*)
end function stdlib_is_directory
end interface
is_directory = logical(stdlib_is_directory(to_c_char(trim(path))))
end function is_directory
! A Helper function to convert C character arrays to Fortran character strings
function to_f_char(c_str_ptr, len) result(f_str)
type(c_ptr), intent(in) :: c_str_ptr
! length of the string excluding the null character
integer(kind=c_size_t), intent(in) :: len
character(:), allocatable :: f_str
integer :: i
character(kind=c_char), pointer :: c_str(:)
call c_f_pointer(c_str_ptr, c_str, [len])
allocate(character(len=len) :: f_str)
do concurrent (i=1:len)
f_str(i:i) = c_str(i)
end do
end function to_f_char
! A helper function to get the string describing an error from C functions.
! If `winapi` is false or not present, uses `strerror` provided by ``
! Otherwise, uses `strerror` on unix and `FormatMessageA` on windows.
function c_get_strerror(winapi) result(str)
character(len=:), allocatable :: str
logical, optional, intent(in) :: winapi
interface
type(c_ptr) function strerror(len, winapi) bind(C, name='stdlib_strerror')
import c_size_t, c_ptr, c_bool
implicit none
integer(c_size_t), intent(out) :: len
logical, intent(in) :: winapi
end function strerror
end interface
type(c_ptr) :: c_str_ptr
integer(c_size_t) :: len, i
character(kind=c_char), pointer :: c_str(:)
logical :: winapi_
winapi_ = optval(winapi, .false.)
c_str_ptr = strerror(len, winapi_)
str = to_f_char(c_str_ptr, len)
end function c_get_strerror
!! makes an empty directory
subroutine make_directory(path, err)
character(len=*), intent(in) :: path
type(state_type), optional, intent(out) :: err
integer :: code
type(state_type) :: err0
interface
integer function stdlib_make_directory(cpath) bind(C, name='stdlib_make_directory')
import c_char
character(kind=c_char), intent(in) :: cpath(*)
end function stdlib_make_directory
end interface
code = stdlib_make_directory(to_c_char(trim(path)))
if (code /= 0) then
err0 = FS_ERROR_CODE(code, c_get_strerror())
call err0%handle(err)
end if
end subroutine make_directory
subroutine make_directory_all(path, err)
character(len=*), intent(in) :: path
type(state_type), optional, intent(out) :: err
integer :: i, indx
type(state_type) :: err0
character(len=1) :: sep
logical :: is_dir, check_is_dir
sep = path_sep()
i = 1
indx = find(path, sep, i)
check_is_dir = .true.
do
! Base case to exit the loop
if (indx == 0) then
is_dir = is_directory(path)
if (.not. is_dir) then
call make_directory(path, err0)
if (err0%error()) then
call err0%handle(err)
end if
end if
return
end if
if (check_is_dir) then
is_dir = is_directory(path(1:indx))
end if
if (.not. is_dir) then
! no need for further `is_dir` checks
! all paths going forward need to be created
check_is_dir = .false.
call make_directory(path(1:indx), err0)
if (err0%error()) then
call err0%handle(err)
return
end if
end if
i = i + 1 ! the next occurence of `sep`
indx = find(path, sep, i)
end do
end subroutine make_directory_all
!! removes an empty directory
subroutine remove_directory(path, err)
character(len=*), intent(in) :: path
type(state_type), optional, intent(out) :: err
integer :: code
type(state_type) :: err0
interface
integer function stdlib_remove_directory(cpath) bind(C, name='stdlib_remove_directory')
import c_char
character(kind=c_char), intent(in) :: cpath(*)
end function stdlib_remove_directory
end interface
code = stdlib_remove_directory(to_c_char(trim(path)))
if (code /= 0) then
err0 = FS_ERROR_CODE(code, c_get_strerror())
call err0%handle(err)
end if
end subroutine remove_directory
subroutine get_cwd(cwd, err)
character(:), allocatable, intent(out) :: cwd
type(state_type), optional, intent(out) :: err
type(state_type) :: err0
interface
type(c_ptr) function stdlib_get_cwd(len, stat) bind(C, name='stdlib_get_cwd')
import c_ptr, c_size_t
integer(c_size_t), intent(out) :: len
integer :: stat
end function stdlib_get_cwd
end interface
type(c_ptr) :: c_str_ptr
integer(c_size_t) :: len
integer :: stat
c_str_ptr = stdlib_get_cwd(len, stat)
if (stat /= 0) then
err0 = FS_ERROR_CODE(stat, c_get_strerror())
call err0%handle(err)
end if
cwd = to_f_char(c_str_ptr, len)
end subroutine get_cwd
subroutine set_cwd(path, err)
character(len=*), intent(in) :: path
type(state_type), optional, intent(out) :: err
type(state_type) :: err0
interface
integer function stdlib_set_cwd(path) bind(C, name='stdlib_set_cwd')
import c_char
character(kind=c_char), intent(in) :: path(*)
end function stdlib_set_cwd
end interface
integer :: code
code = stdlib_set_cwd(to_c_char(trim(path)))
if (code /= 0) then
err0 = FS_ERROR_CODE(code, c_get_strerror())
call err0%handle(err)
end if
end subroutine set_cwd
!> Returns the file path of the null device for the current operating system.
!>
!> Version: Helper function.
function null_device() result(path)
!> File path of the null device
character(:), allocatable :: path
interface
! No-overhead return path to the null device
type(c_ptr) function process_null_device(len) bind(C,name='process_null_device')
import c_ptr, c_size_t
implicit none
integer(c_size_t), intent(out) :: len
end function process_null_device
end interface
integer(c_size_t) :: len
type(c_ptr) :: c_path_ptr
! Call the C function to get the null device path and its length
c_path_ptr = process_null_device(len)
path = to_f_char(c_path_ptr, len)
end function null_device
!> Delete a file at the given path.
subroutine delete_file(path, err)
character(*), intent(in) :: path
type(state_type), optional, intent(out) :: err
!> Local variables
integer :: file_unit, ios
type(state_type) :: err0
character(len=512) :: msg
logical :: file_exists
! Verify the file is not a directory.
if (is_directory(path)) then
! If unable to open, assume it's a directory or inaccessible
err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'- is a directory')
call err0%handle(err)
return
end if
! Check if the path exists
! Because Intel compilers return .false. if path is a directory, this must be tested
! _after_ the directory test
inquire(file=path, exist=file_exists)
if (.not. file_exists) then
! File does not exist, return non-error status
err0 = state_type(STDLIB_SUCCESS,path,' not deleted: file does not exist')
call err0%handle(err)
return
endif
! Close and delete the file
open(newunit=file_unit, file=path, status='old', iostat=ios, iomsg=msg)
if (ios /= 0) then
err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'-',msg)
call err0%handle(err)
return
end if
close(unit=file_unit, status='delete', iostat=ios, iomsg=msg)
if (ios /= 0) then
err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'-',msg)
call err0%handle(err)
return
end if
end subroutine delete_file
pure function FS_ERROR_CODE(code,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,&
a11,a12,a13,a14,a15,a16,a17,a18,a19) result(state)
type(state_type) :: state
!> Platform specific error code
integer, intent(in) :: code
!> Optional rank-agnostic arguments
class(*), intent(in), optional, dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,&
a11,a12,a13,a14,a15,a16,a17,a18,a19
character(32) :: code_msg
write(code_msg, "('code - ', i0, ',')") code
state = state_type(STDLIB_FS_ERROR, code_msg,a1,a2,a3,a4,a5,a6,a7,a8,&
a9,a10,a11,a12,a13,a14,a15,a16,a17,a18,a19)
end function FS_ERROR_CODE
pure function FS_ERROR(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,&
a12,a13,a14,a15,a16,a17,a18,a19,a20) result(state)
type(state_type) :: state
!> Optional rank-agnostic arguments
class(*), intent(in), optional, dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,&
a11,a12,a13,a14,a15,a16,a17,a18,a19,a20
state = state_type(STDLIB_FS_ERROR, a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,&
a13,a14,a15,a16,a17,a18,a19,a20)
end function FS_ERROR
! checks if a path exists and returns its type
function exists(path, err) result(fs_type)
character(*), intent(in) :: path
type(state_type), optional, intent(out) :: err
integer :: fs_type
type(state_type) :: err0
interface
integer function stdlib_exists(path, stat) bind(C, name='stdlib_exists')
import c_char, c_int
character(kind=c_char), intent(in) :: path(*)
! to return the error code if any
integer(kind=c_int), intent(out) :: stat
end function stdlib_exists
end interface
integer(kind=c_int) :: stat
fs_type = stdlib_exists(to_c_char(trim(path)), stat)
! an error occurred
if (stat /= 0) then
err0 = FS_ERROR_CODE(stat, c_get_strerror())
call err0%handle(err)
end if
end function exists
! public convenience wrapper to check if path is a symbolic link
logical function is_symlink(path)
character(len=*), intent(in) :: path
type(state_type) :: err
is_symlink = exists(path, err) == fs_type_symlink
end function is_symlink
! checks if path is a regular file.
! It follows symbolic links and returns the status of the `target`.
logical function is_file(path)
character(len=*), intent(in) :: path
interface
logical(c_bool) function stdlib_is_file(path) bind(C, name='stdlib_is_file')
import c_char, c_bool
character(kind=c_char) :: path(*)
end function stdlib_is_file
end interface
is_file = logical(stdlib_is_file(to_c_char(trim(path))))
end function is_file
character function path_sep()
if (OS_TYPE() == OS_WINDOWS) then
path_sep = '\'
else
path_sep = '/'
end if
end function path_sep
end module stdlib_system
fortran-lang-stdlib-0ede301/src/system/stdlib_system.c 0000664 0001750 0001750 00000011611 15135654166 023332 0 ustar alastair alastair #include
#include
#include
#include
#include
#include
#include
#include
#ifdef _WIN32
#include
#include
#ifndef S_ISREG
#if defined(S_IFMT) && defined(S_IFREG)
#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
#elif defined(_S_IFMT) && defined(_S_IFREG)
#define S_ISREG(mode) (((mode) & _S_IFMT) == _S_IFREG)
#endif
#endif /* ifndef S_ISREG */
#else
#include
#endif /* ifdef _WIN32 */
// Wrapper to get the string describing a system syscall error.
// Always Uses `strerr` on unix.
// if `winapi` is `false`, uses the usual `strerr` on windows.
// If `winapi` is `true`, uses `FormatMessageA`(from windows.h) on windows.
char* stdlib_strerror(size_t* len, bool winapi){
if (winapi) {
#ifdef _WIN32
LPSTR err = NULL;
DWORD dw = GetLastError();
FormatMessageA(
FORMAT_MESSAGE_ALLOCATE_BUFFER |
FORMAT_MESSAGE_FROM_SYSTEM |
FORMAT_MESSAGE_IGNORE_INSERTS,
NULL,
dw,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
(LPSTR) &err,
0,
NULL);
*len = strlen(err);
return (char*) err;
#endif /* ifdef _WIN32 */
}
char* err = strerror(errno);
*len = strlen(err);
return err;
}
// Wrapper to the platform's `mkdir`(make directory) call.
// Uses `mkdir` on unix, `_mkdir` on windows.
// Returns 0 if successful, otherwise returns the `errno`.
int stdlib_make_directory(const char* path){
int code;
#ifdef _WIN32
code = _mkdir(path);
#else
// Default mode 0777
code = mkdir(path, 0777);
#endif /* ifdef _WIN32 */
return (!code) ? 0 : errno;
}
// Wrapper to the platform's `rmdir`(remove directory) call.
// Uses `rmdir` on unix, `_rmdir` on windows.
// Returns 0 if successful, otherwise returns the `errno`.
int stdlib_remove_directory(const char* path){
int code;
#ifdef _WIN32
code = _rmdir(path);
#else
code = rmdir(path);
#endif /* ifdef _WIN32 */
return (!code) ? 0 : errno;
}
// Wrapper to the platform's `getcwd`(get current working directory) call.
// Uses `getcwd` on unix, `_getcwd` on windows.
// Returns the cwd, sets the length of cwd and the `stat` of the operation.
char* stdlib_get_cwd(size_t* len, int* stat){
*stat = 0;
#ifdef _WIN32
char* buffer;
buffer = _getcwd(NULL, 0);
if (buffer == NULL) {
*stat = errno;
return NULL;
}
*len = strlen(buffer);
return buffer;
#else
char buffer[PATH_MAX + 1];
if (!getcwd(buffer, sizeof(buffer))) {
*stat = errno;
}
*len = strlen(buffer);
char* res = malloc(*len + 1); // Allocate space for null terminator
if (res == NULL) {
*stat = ENOMEM; // Set error code for memory allocation failure
return NULL;
}
strncpy(res, buffer, *len);
res[*len] = '\0'; // Ensure null termination
return res;
#endif /* ifdef _WIN32 */
}
// Wrapper to the platform's `chdir`(change directory) call.
// Uses `chdir` on unix, `_chdir` on windows.
// Returns 0 if successful, otherwise returns the `errno`.
int stdlib_set_cwd(const char* path) {
int code;
#ifdef _WIN32
code = _chdir(path);
#else
code = chdir(path);
#endif /* ifdef _WIN32 */
return (code == -1) ? errno : 0;
}
// Wrapper to the platform's `stat`(status of path) call.
// Uses `lstat` on unix, `GetFileAttributesA` on windows.
// Returns the `type` of the path, and sets the `stat`(if any errors).
int stdlib_exists(const char* path, int* stat){
// All the valid types
const int fs_type_unknown = 0;
const int fs_type_regular_file = 1;
const int fs_type_directory = 2;
const int fs_type_symlink = 3;
int type = fs_type_unknown;
*stat = 0;
#ifdef _WIN32
DWORD attrs = GetFileAttributesA(path);
if (attrs == INVALID_FILE_ATTRIBUTES) {
*stat = (int) GetLastError();
return fs_type_unknown;
}
// Let's assume it is a regular file
type = fs_type_regular_file;
if (attrs & FILE_ATTRIBUTE_REPARSE_POINT) type = fs_type_symlink;
if (attrs & FILE_ATTRIBUTE_DIRECTORY) type = fs_type_directory;
#else
struct stat buf = {0};
int status;
status = lstat(path, &buf);
if (status == -1) {
// `lstat` failed
*stat = errno;
return fs_type_unknown;
}
switch (buf.st_mode & S_IFMT) {
case S_IFREG: type = fs_type_regular_file; break;
case S_IFDIR: type = fs_type_directory; break;
case S_IFLNK: type = fs_type_symlink; break;
default: type = fs_type_unknown; break;
}
#endif /* ifdef _WIN32 */
return type;
}
// `stat` and `_stat` follow symlinks automatically.
// so no need for winapi functions.
bool stdlib_is_file(const char* path) {
#ifdef _WIN32
struct _stat buf = {0};
return _stat(path, &buf) == 0 && S_ISREG(buf.st_mode);
#else
struct stat buf = {0};
return stat(path, &buf) == 0 && S_ISREG(buf.st_mode);
#endif /* ifdef _WIN32 */
}
fortran-lang-stdlib-0ede301/src/system/CMakeLists.txt 0000664 0001750 0001750 00000000665 15135654166 023050 0 ustar alastair alastair set(system_fppFiles
)
set(system_cppFiles
)
set(system_f90Files
stdlib_system_subprocess.c
stdlib_system_subprocess.F90
stdlib_system_path.f90
stdlib_system.c
stdlib_system.F90
)
configure_stdlib_target(${PROJECT_NAME}_system system_f90Files system_fppFiles system_cppFiles)
target_link_libraries(${PROJECT_NAME}_system PUBLIC ${PROJECT_NAME}_core ${PROJECT_NAME}_linalg_core ${PROJECT_NAME}_strings)
fortran-lang-stdlib-0ede301/src/system/stdlib_system_subprocess.c 0000664 0001750 0001750 00000030740 15135654166 025606 0 ustar alastair alastair #include
#include
#include
#include
#include
#include
#ifdef _WIN32
#include
#else
#define _POSIX_C_SOURCE 199309L
#include
#include
#include
#include
#include
#include
#endif // _WIN32
// Typedefs
typedef void* stdlib_handle;
typedef int64_t stdlib_pid;
/////////////////////////////////////////////////////////////////////////////////////
// Windows-specific code
/////////////////////////////////////////////////////////////////////////////////////
#ifdef _WIN32
// On Windows systems: create a new process
void process_create_windows(const char* cmd, const char* stdin_stream,
const char* stdin_file, const char* stdout_file, const char* stderr_file,
stdlib_pid* pid) {
STARTUPINFO si;
PROCESS_INFORMATION pi;
HANDLE hStdout = NULL, hStderr = NULL, hStdin = NULL;
SECURITY_ATTRIBUTES sa = { sizeof(SECURITY_ATTRIBUTES), NULL, TRUE };
FILE* stdin_fp = NULL;
char* full_cmd = NULL;
// Initialize null handle
(*pid) = 0;
ZeroMemory(&si, sizeof(si));
si.cb = sizeof(STARTUPINFO);
// Write stdin_stream to stdin_file if provided
if (stdin_stream && stdin_file) {
stdin_fp = fopen(stdin_file, "w");
if (!stdin_fp) {
fprintf(stderr, "Failed to open stdin file for writing\n");
return;
}
fputs(stdin_stream, stdin_fp);
fclose(stdin_fp);
}
// Open stdin file if provided, otherwise use the null device
if (stdin_file) {
hStdin = CreateFile(stdin_file, GENERIC_READ, 0, &sa, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
hStdin = CreateFile("NUL", GENERIC_READ, 0, &sa, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
}
if (hStdin == INVALID_HANDLE_VALUE) {
fprintf(stderr, "Failed to open input source (file or null)\n");
// No handles to close yet
return;
}
si.hStdInput = hStdin;
si.dwFlags |= STARTF_USESTDHANDLES;
// Open stdout file if provided, otherwise use the null device
if (stdout_file) {
hStdout = CreateFile(stdout_file, GENERIC_WRITE, 0, &sa, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
hStdout = CreateFile("NUL", GENERIC_WRITE, 0, &sa, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
}
if (hStdout == INVALID_HANDLE_VALUE) {
fprintf(stderr, "Failed to open stdout sink\n");
CloseHandle(hStdin);
return;
}
si.hStdOutput = hStdout;
// Open stderr file if provided, otherwise use the null device
if (stderr_file) {
hStderr = CreateFile(stderr_file, GENERIC_WRITE, 0, &sa, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
hStderr = CreateFile("NUL", GENERIC_WRITE, 0, &sa, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
}
if (hStderr == INVALID_HANDLE_VALUE) {
fprintf(stderr, "Failed to open stderr sink\n");
CloseHandle(hStdin);
CloseHandle(hStdout);
return;
}
si.hStdError = hStderr;
// Prepare the command line
size_t cmd_len = strlen(cmd);
size_t full_cmd_len = cmd_len + 1;
full_cmd = (char*)malloc(full_cmd_len);
if (!full_cmd) {
fprintf(stderr, "Failed to allocate memory for full_cmd\n");
CloseHandle(hStdin);
CloseHandle(hStdout);
CloseHandle(hStderr);
return;
}
// Use full_cmd as needed (e.g., pass to CreateProcess)
snprintf(full_cmd, full_cmd_len, "%s", cmd);
// Create the process
BOOL success = CreateProcess(
NULL, // Application name
full_cmd, // Command line
NULL, // Process security attributes
NULL, // Thread security attributes
TRUE, // Inherit handles
0, // Creation flags
NULL, // Environment variables
NULL, // Current directory
&si, // STARTUPINFO
&pi // PROCESS_INFORMATION
);
// Free the allocated memory
free(full_cmd);
if (!success) {
fprintf(stderr, "CreateProcess failed (%lu).\n", GetLastError());
CloseHandle(hStdin);
CloseHandle(hStdout);
CloseHandle(hStderr);
return;
}
// Close unneeded handles (the child has its own duplicates now)
CloseHandle(hStdin);
CloseHandle(hStdout);
CloseHandle(hStderr);
// Return the process handle for status queries
CloseHandle(pi.hThread); // Close the thread handle
(*pid) = (stdlib_pid) pi.dwProcessId;
}
// Query process state on a Windows system
void process_query_status_windows(stdlib_pid pid, bool wait, bool* is_running, int* exit_code)
{
int wait_code;
HANDLE hProcess;
DWORD dwExitCode,dwPid;
dwPid = (DWORD) pid;
// Open the process with the appropriate access rights
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION | SYNCHRONIZE, FALSE, dwPid);
// Error opening the process, likely pid does not exist
if (hProcess == NULL) {
*is_running = false;
*exit_code = -1;
return;
}
if (wait) {
// Wait for the process to terminate
wait_code = WaitForSingleObject(hProcess, INFINITE);
} else {
// Check if the process has terminated
wait_code = WaitForSingleObject(hProcess, 0);
}
if (wait_code == WAIT_OBJECT_0) {
// Process has exited, get the exit code
*is_running = false;
if (GetExitCodeProcess(hProcess, &dwExitCode)) {
*exit_code = dwExitCode;
} else {
*exit_code = -1; // Error retrieving the exit code
}
} else if (wait_code == WAIT_TIMEOUT) {
// Process is still running
*is_running = true;
*exit_code = 0;
} else { // WAIT_FAILED
// Error occurred
*is_running = false;
*exit_code = -1; // Error occurred in WaitForSingleObject
}
// Close the process handle
CloseHandle(hProcess);
}
// Kill a process on Windows by sending a PROCESS_TERMINATE signal.
// Return true if the operation succeeded, or false if it failed (process does not
// exist anymore, or we may not have the rights to kill the process).
bool process_kill_windows(stdlib_pid pid) {
HANDLE hProcess;
DWORD dwPid;
dwPid = (DWORD) pid;
// Open the process with terminate rights
hProcess = OpenProcess(PROCESS_TERMINATE, FALSE, dwPid);
if (hProcess == NULL) {
// Failed to open the process; return false
return false;
}
// Attempt to terminate the process
if (!TerminateProcess(hProcess, 1)) {
// Failed to terminate the process
CloseHandle(hProcess);
return false;
}
// Successfully terminated the process
CloseHandle(hProcess);
return true;
}
// Check if input path is a directory
bool stdlib_is_directory_windows(const char *path) {
DWORD attrs = GetFileAttributesA(path);
return (attrs != INVALID_FILE_ATTRIBUTES) // Path exists
&& (attrs & FILE_ATTRIBUTE_DIRECTORY); // Path is a directory
}
#else // _WIN32
/////////////////////////////////////////////////////////////////////////////////////
// Unix-specific code
/////////////////////////////////////////////////////////////////////////////////////
void process_query_status_unix(stdlib_pid pid, bool wait, bool* is_running, int* exit_code)
{
int status;
int wait_code;
// Wait or return immediately if no status change
int options = wait ? 0 : WNOHANG;
// Call waitpid to check the process state
wait_code = waitpid(pid, &status, options);
if (wait_code > 0) {
// Process state was updated
if (WIFEXITED(status)) {
*is_running = false;
// Get exit code
*exit_code = WEXITSTATUS(status);
} else if (WIFSIGNALED(status)) {
*is_running = false;
// Use negative value to indicate termination by signal
*exit_code = -WTERMSIG(status);
} else {
// Process is still running: no valid exit code yet
*is_running = true;
*exit_code = 0;
}
} else if (wait_code == 0) {
// No status change; process is still running
*is_running = true;
*exit_code = 0;
} else {
// Error occurred
*is_running = false;
*exit_code = -1; // Indicate an error
}
}
// Kill a process by sending a SIGKILL signal. Return .true. if succeeded, or false if not.
// Killing process may fail due to unexistent process, or not enough rights to kill.
bool process_kill_unix(stdlib_pid pid) {
// Send the SIGKILL signal to the process
if (kill(pid, SIGKILL) == 0) {
// Successfully sent the signal
return true;
}
// If `kill` fails, check if the process no longer exists
if (errno == ESRCH) {
// Process does not exist
return true; // Already "terminated"
}
// Other errors occurred
return false;
}
// On UNIX systems: just fork a new process. The command line will be executed from Fortran.
void process_create_posix(stdlib_pid* pid)
{
(*pid) = (stdlib_pid) fork();
}
// On UNIX systems: check if input path is a directory
bool stdlib_is_directory_posix(const char *path) {
struct stat sb;
return stat(path, &sb) == 0 && S_ISDIR(sb.st_mode);
}
#endif // _WIN32
/////////////////////////////////////////////////////////////////////////////////////
// Cross-platform interface
/////////////////////////////////////////////////////////////////////////////////////
// Cross-platform interface: query directory state
bool stdlib_is_directory(const char *path) {
// Invalid input
if (path == NULL || strlen(path) == 0) return false;
#ifdef _WIN32
return stdlib_is_directory_windows(path);
#else
return stdlib_is_directory_posix(path);
#endif // _WIN32
}
// Create or fork process
void process_create(const char* cmd, const char* stdin_stream, const char* stdin_file,
const char* stdout_file, const char* stderr_file,
stdlib_pid* pid) {
#ifdef _WIN32
process_create_windows(cmd, stdin_stream, stdin_file, stdout_file, stderr_file, pid);
#else
process_create_posix(pid);
#endif // _WIN32
}
// Cross-platform interface: query process state
void process_query_status(stdlib_pid pid, bool wait, bool* is_running, int* exit_code)
{
#ifdef _WIN32
process_query_status_windows(pid, wait, is_running, exit_code);
#else
process_query_status_unix (pid, wait, is_running, exit_code);
#endif // _WIN32
}
// Cross-platform interface: kill process by ID
bool process_kill(stdlib_pid pid)
{
#ifdef _WIN32
return process_kill_windows(pid);
#else
return process_kill_unix(pid);
#endif // _WIN32
}
// Cross-platform interface: sleep(seconds)
void process_wait(float seconds)
{
#ifdef _WIN32
DWORD dwMilliseconds = (DWORD) (seconds * 1000);
Sleep(dwMilliseconds);
#else
int ierr;
unsigned int ms = (unsigned int) (seconds * 1000);
struct timespec ts_remaining =
{
ms / 1000,
(ms % 1000) * 1000000L
};
do
{
struct timespec ts_sleep = ts_remaining;
ierr = nanosleep(&ts_sleep, &ts_remaining);
}
while ((EINTR == errno) && (-1 == ierr));
if (ierr != 0){
switch(errno){
case EINTR:
fprintf(stderr, "nanosleep() interrupted\n");
break;
case EINVAL:
fprintf(stderr, "nanosleep() bad milliseconds value\n");
exit(EINVAL);
case EFAULT:
fprintf(stderr, "nanosleep() problem copying information to user space\n");
exit(EFAULT);
case ENOSYS:
fprintf(stderr, "nanosleep() not supported on this system\n");
exit(ENOSYS);
default:
fprintf(stderr, "nanosleep() error\n");
exit(1);
}
}
#endif // _WIN32
}
// Returns the cross-platform file path of the null device for the current operating system.
const char* process_null_device(size_t* len)
{
#ifdef _WIN32
(*len) = strlen("NUL");
return "NUL";
#else
(*len) = strlen("/dev/null");
return "/dev/null";
#endif
}
// Returns a boolean flag if macro _WIN32 is defined
bool process_is_windows()
{
#ifdef _WIN32
return true;
#else
return false;
#endif // _WIN32
}
fortran-lang-stdlib-0ede301/src/lapack/ 0000775 0001750 0001750 00000000000 15135654166 020210 5 ustar alastair alastair fortran-lang-stdlib-0ede301/src/lapack/stdlib_lapack_solve_ldl_comp.fypp 0000664 0001750 0001750 00003020217 15135654166 026772 0 ustar alastair alastair #:include "common.fypp"
submodule(stdlib_lapack_solve) stdlib_lapack_solve_ldl_comp
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_ssycon( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
!! SSYCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by SSYTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(in) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(sp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_ssytrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_ssycon
pure module subroutine stdlib${ii}$_dsycon( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
!! DSYCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by DSYTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(in) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(dp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_dsytrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_dsycon
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sycon( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info )
!! DSYCON: estimates the reciprocal of the condition number (in the
!! 1-norm) of a real symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by DSYTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${rk}$), intent(in) :: anorm
real(${rk}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(in) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(${rk}$) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_${ri}$sytrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ri}$sycon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! CSYCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by CSYTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(sp), intent(in) :: anorm
real(sp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(sp), intent(in) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(sp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_csytrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_csycon
pure module subroutine stdlib${ii}$_zsycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! ZSYCON estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(dp), intent(in) :: anorm
real(dp), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(dp), intent(in) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(dp) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_zsytrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_zsycon
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info )
!! ZSYCON: estimates the reciprocal of the condition number (in the
!! 1-norm) of a complex symmetric matrix A using the factorization
!! A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.
!! An estimate is obtained for norm(inv(A)), and the reciprocal of the
!! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
real(${ck}$), intent(in) :: anorm
real(${ck}$), intent(out) :: rcond
! Array Arguments
integer(${ik}$), intent(in) :: ipiv(*)
complex(${ck}$), intent(in) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, kase
real(${ck}$) :: ainvnm
! Local Arrays
integer(${ik}$) :: isave(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda0 .and. a( i, i )==zero )return
end do
else
! lower triangular storage: examine d from top to bottom.
do i = 1, n
if( ipiv( i )>0 .and. a( i, i )==zero )return
end do
end if
! estimate the 1-norm of the inverse.
kase = 0_${ik}$
30 continue
call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave )
if( kase/=0_${ik}$ ) then
! multiply by inv(l*d*l**t) or inv(u*d*u**t).
call stdlib${ii}$_${ci}$sytrs( uplo, n, 1_${ik}$, a, lda, ipiv, work, n, info )
go to 30
end if
! compute the estimate of the reciprocal condition number.
if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm
return
end subroutine stdlib${ii}$_${ci}$sycon
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! SSYTRF computes the factorization of a real symmetric matrix A using
!! the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U**T*D*U or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda1_${ik}$ .and. nbnb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_slasyf( uplo, k, nb, kb, a, lda, ipiv, work, ldwork,iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_ssytf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_slasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, ldwork, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_ssytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssytrf
pure module subroutine stdlib${ii}$_dsytrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! DSYTRF computes the factorization of a real symmetric matrix A using
!! the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U**T*D*U or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda1_${ik}$ .and. nbnb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_dlasyf( uplo, k, nb, kb, a, lda, ipiv, work, ldwork,iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_dsytf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_dlasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, ldwork, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_dsytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsytrf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! DSYTRF: computes the factorization of a real symmetric matrix A using
!! the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U**T*D*U or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda1_${ik}$ .and. nbnb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_${ri}$lasyf( uplo, k, nb, kb, a, lda, ipiv, work, ldwork,iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_${ri}$sytf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_${ri}$lasyf;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_${ri}$lasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, ldwork, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_${ri}$sytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sytrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csytrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! CSYTRF computes the factorization of a complex symmetric matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda1_${ik}$ .and. nbnb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_clasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_csytf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_clasyf;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_clasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_csytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_csytrf
pure module subroutine stdlib${ii}$_zsytrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! ZSYTRF computes the factorization of a complex symmetric matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda1_${ik}$ .and. nbnb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_zlasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_zsytf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_zlasyf;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_zlasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_zsytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zsytrf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info )
!! ZSYTRF: computes the factorization of a complex symmetric matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The form of the
!! factorization is
!! A = U*D*U**T or A = L*D*L**T
!! where U (or L) is a product of permutation and unit upper (lower)
!! triangular matrices, and D is symmetric and block diagonal with
!! 1-by-1 and 2-by-2 diagonal blocks.
!! This is the blocked version of the algorithm, calling Level 3 BLAS.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda1_${ik}$ .and. nbnb ) then
! factorize columns k-kb+1:k of a and use blocked code to
! update columns 1:k-kb
call stdlib${ii}$_${ci}$lasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo )
else
! use unblocked code to factorize columns 1:k of a
call stdlib${ii}$_${ci}$sytf2( uplo, k, a, lda, ipiv, iinfo )
kb = k
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo
! decrease k and return to the start of the main loop
k = k - kb
go to 10
else
! factorize a as l*d*l**t using the lower triangle of a
! k is the main loop index, increasing from 1 to n in steps of
! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf;
! kb is either nb or nb-1, or n-k+1 for the last block
k = 1_${ik}$
20 continue
! if k > n, exit from loop
if( k>n )go to 40
if( k<=n-nb ) then
! factorize columns k:k+kb-1 of a and use blocked code to
! update columns k+kb:n
call stdlib${ii}$_${ci}$lasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, &
iinfo )
else
! use unblocked code to factorize columns k:n of a
call stdlib${ii}$_${ci}$sytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo )
kb = n - k + 1_${ik}$
end if
! set info on the first occurrence of a zero pivot
if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$
! adjust ipiv
do j = k, k + kb - 1
if( ipiv( j )>0_${ik}$ ) then
ipiv( j ) = ipiv( j ) + k - 1_${ik}$
else
ipiv( j ) = ipiv( j ) - k + 1_${ik}$
end if
end do
! increase k and return to the start of the main loop
k = k + kb
go to 20
end if
40 continue
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$sytrf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info )
!! SLASYF computes a partial factorization of a real symmetric matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The partial
!! factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code
!! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
!! A22 (if UPLO = 'L').
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(sp), parameter :: sevten = 17.0e+0_sp
! Local Scalars
integer(${ik}$) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw
real(sp) :: absakk, alpha, colmax, d11, d21, d22, r1, rowmax, t
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
! kw is the column of w which corresponds to column k of a
k = n
10 continue
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb1_${ik}$ ) then
imax = stdlib${ii}$_isamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = abs( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_scopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_scopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k1_${ik}$ ) then
jmax = stdlib${ii}$_isamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
rowmax = max( rowmax, abs( w( jmax, kw-1 ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( w( imax, kw-1 ) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kkw of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k-1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = a( kk, kk )
call stdlib${ii}$_scopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
if( kp>1_${ik}$ )call stdlib${ii}$_scopy( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last k+1 to n columns of a
! (columns k (or k and k-1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in last kkw to nb columns of w.
if( k2_${ik}$ ) then
! compose the columns of the inverse of 2-by-2 pivot
! block d in the following way to reduce the number
! of flops when we myltiply panel ( w(kw-1) w(kw) ) by
! this inverse
! d**(-1) = ( d11 d21 )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
! ( (-d21 ) ( d11 ) )
! = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
! * ( ( d22/d21 ) ( -1 ) ) =
! ( ( -1 ) ( d11/d21 ) )
! = 1/d21 * 1/(d22*d11-1) * ( ( d11 ) ( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = 1/d21 * t * ( ( d11 ) ( -1 ) )
! ( ( -1 ) ( d22 ) )
! = d21 * ( ( d11 ) ( -1 ) )
! ( ( -1 ) ( d22 ) )
d21 = w( k-1, kw )
d11 = w( k, kw ) / d21
d22 = w( k-1, kw-1 ) / d21
t = one / ( d11*d22-one )
d21 = t / d21
! update elements in columns a(k-1) and a(k) as
! dot products of rows of ( w(kw-1) w(kw) ) and columns
! of d**(-1)
do j = 1, k - 2
a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) )
a( j, k ) = d21*( d22*w( j, kw )-w( j, kw-1 ) )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) 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
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k, -one,a( 1_${ik}$, k+1 ), &
lda, w( j, kw+1 ), ldw, one,a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n looping backwards from k+1 to n
j = k + 1_${ik}$
60 continue
! undo the interchanges (if any) of rows jj and jp at each
! step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j + 1_${ik}$
end if
! (note: here, j is used to determine row length. length n-j+1
! of the rows to swap back doesn't include diagonal element)
j = j + 1_${ik}$
if( jp/=jj .and. j<=n )call stdlib${ii}$_sswap( n-j+1, a( jp, j ), lda, a( jj, j ), &
lda )
if( j=nb .and. nbn )go to 90
! copy column k of a to column k of w and update it
call stdlib${ii}$_scopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw, &
one, w( k, k ), 1_${ik}$ )
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ )
call stdlib${ii}$_scopy( n-imax+1, a( imax, imax ), 1_${ik}$, w( imax, k+1 ),1_${ik}$ )
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( imax, &
1_${ik}$ ), ldw, one, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
jmax = k - 1_${ik}$ + stdlib${ii}$_isamax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = abs( w( jmax, k+1 ) )
if( imax=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( w( imax, k+1 ) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_scopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k + kstep - 1_${ik}$
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kk of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k+1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = a( kk, kk )
call stdlib${ii}$_scopy( kp-kk-1, a( kk+1, kk ), 1_${ik}$, a( kp, kk+1 ),lda )
if( kp1_${ik}$ )call stdlib${ii}$_sswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_sswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k),
! where l(k) is the k-th column of l
! store subdiag. elements of column l(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element l(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,k)
! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k)
call stdlib${ii}$_scopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k=1_${ik}$ )call stdlib${ii}$_sswap( j, a( jp, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
if( j>1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_slasyf
pure module subroutine stdlib${ii}$_dlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info )
!! DLASYF computes a partial factorization of a real symmetric matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The partial
!! factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code
!! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
!! A22 (if UPLO = 'L').
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(dp), parameter :: sevten = 17.0e+0_dp
! Local Scalars
integer(${ik}$) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw
real(dp) :: absakk, alpha, colmax, d11, d21, d22, r1, rowmax, t
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
! kw is the column of w which corresponds to column k of a
k = n
10 continue
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb1_${ik}$ ) then
imax = stdlib${ii}$_idamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = abs( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_dcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k1_${ik}$ ) then
jmax = stdlib${ii}$_idamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
rowmax = max( rowmax, abs( w( jmax, kw-1 ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( w( imax, kw-1 ) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kkw of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k-1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = a( kk, kk )
call stdlib${ii}$_dcopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
if( kp>1_${ik}$ )call stdlib${ii}$_dcopy( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last k+1 to n columns of a
! (columns k (or k and k-1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in last kkw to nb columns of w.
if( k2_${ik}$ ) then
! compose the columns of the inverse of 2-by-2 pivot
! block d in the following way to reduce the number
! of flops when we myltiply panel ( w(kw-1) w(kw) ) by
! this inverse
! d**(-1) = ( d11 d21 )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
! ( (-d21 ) ( d11 ) )
! = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
! * ( ( d22/d21 ) ( -1 ) ) =
! ( ( -1 ) ( d11/d21 ) )
! = 1/d21 * 1/(d22*d11-1) * ( ( d11 ) ( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = 1/d21 * t * ( ( d11 ) ( -1 ) )
! ( ( -1 ) ( d22 ) )
! = d21 * ( ( d11 ) ( -1 ) )
! ( ( -1 ) ( d22 ) )
d21 = w( k-1, kw )
d11 = w( k, kw ) / d21
d22 = w( k-1, kw-1 ) / d21
t = one / ( d11*d22-one )
d21 = t / d21
! update elements in columns a(k-1) and a(k) as
! dot products of rows of ( w(kw-1) w(kw) ) and columns
! of d**(-1)
do j = 1, k - 2
a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) )
a( j, k ) = d21*( d22*w( j, kw )-w( j, kw-1 ) )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) 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
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k, -one,a( 1_${ik}$, k+1 ), &
lda, w( j, kw+1 ), ldw, one,a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n looping backwards from k+1 to n
j = k + 1_${ik}$
60 continue
! undo the interchanges (if any) of rows jj and jp at each
! step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j + 1_${ik}$
end if
! (note: here, j is used to determine row length. length n-j+1
! of the rows to swap back doesn't include diagonal element)
j = j + 1_${ik}$
if( jp/=jj .and. j<=n )call stdlib${ii}$_dswap( n-j+1, a( jp, j ), lda, a( jj, j ), &
lda )
if( j=nb .and. nbn )go to 90
! copy column k of a to column k of w and update it
call stdlib${ii}$_dcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw, &
one, w( k, k ), 1_${ik}$ )
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_dcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( n-imax+1, a( imax, imax ), 1_${ik}$, w( imax, k+1 ),1_${ik}$ )
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( imax, &
1_${ik}$ ), ldw, one, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
jmax = k - 1_${ik}$ + stdlib${ii}$_idamax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = abs( w( jmax, k+1 ) )
if( imax=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( w( imax, k+1 ) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k + kstep - 1_${ik}$
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kk of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k+1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = a( kk, kk )
call stdlib${ii}$_dcopy( kp-kk-1, a( kk+1, kk ), 1_${ik}$, a( kp, kk+1 ),lda )
if( kp1_${ik}$ )call stdlib${ii}$_dswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_dswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k),
! where l(k) is the k-th column of l
! store subdiag. elements of column l(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element l(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,k)
! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k)
call stdlib${ii}$_dcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k=1_${ik}$ )call stdlib${ii}$_dswap( j, a( jp, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda )
if( j>1 )go to 120
! set kb to the number of columns factorized
kb = k - 1_${ik}$
end if
return
end subroutine stdlib${ii}$_dlasyf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$lasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info )
!! DLASYF: computes a partial factorization of a real symmetric matrix A
!! using the Bunch-Kaufman diagonal pivoting method. The partial
!! factorization has the form:
!! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
!! ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
!! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L'
!! ( L21 I ) ( 0 A22 ) ( 0 I )
!! where the order of D is at most NB. The actual order is returned in
!! the argument KB, and is either NB or NB-1, or N if N <= NB.
!! DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code
!! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
!! A22 (if UPLO = 'L').
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info, kb
integer(${ik}$), intent(in) :: lda, ldw, n, nb
! Array Arguments
integer(${ik}$), intent(out) :: ipiv(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: w(ldw,*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: sevten = 17.0e+0_${rk}$
! Local Scalars
integer(${ik}$) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw
real(${rk}$) :: absakk, alpha, colmax, d11, d21, d22, r1, rowmax, t
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! initialize alpha for use in choosing pivot block size.
alpha = ( one+sqrt( sevten ) ) / eight
if( stdlib_lsame( uplo, 'U' ) ) then
! factorize the trailing columns of a using the upper triangle
! of a and working backwards, and compute the matrix w = u12*d
! for use in updating a11
! k is the main loop index, decreasing from n in steps of 1 or 2
! kw is the column of w which corresponds to column k of a
k = n
10 continue
kw = nb + k - n
! exit from loop
if( ( k<=n-nb+1 .and. nb1_${ik}$ ) then
imax = stdlib${ii}$_i${ri}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ )
colmax = abs( w( imax, kw ) )
else
colmax = zero
end if
if( max( absakk, colmax )==zero ) then
! column k is zero or underflow: set info and continue
if( info==0_${ik}$ )info = k
kp = k
else
if( absakk>=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! copy column imax to column kw-1 of w and update it
call stdlib${ii}$_${ri}$copy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ )
if( k1_${ik}$ ) then
jmax = stdlib${ii}$_i${ri}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ )
rowmax = max( rowmax, abs( w( jmax, kw-1 ) ) )
end if
if( absakk>=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( w( imax, kw-1 ) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column kw-1 of w to column kw of w
call stdlib${ii}$_${ri}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ )
else
! interchange rows and columns k-1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k - kstep + 1_${ik}$
! kkw is the column of w which corresponds to column kk of a
kkw = nb + kk - n
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kkw of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k-1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = a( kk, kk )
call stdlib${ii}$_${ri}$copy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda )
if( kp>1_${ik}$ )call stdlib${ii}$_${ri}$copy( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ )
! interchange rows kk and kp in last k+1 to n columns of a
! (columns k (or k and k-1 for 2-by-2 pivot) of a will be
! later overwritten). interchange rows kk and kp
! in last kkw to nb columns of w.
if( k2_${ik}$ ) then
! compose the columns of the inverse of 2-by-2 pivot
! block d in the following way to reduce the number
! of flops when we myltiply panel ( w(kw-1) w(kw) ) by
! this inverse
! d**(-1) = ( d11 d21 )**(-1) =
! ( d21 d22 )
! = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) =
! ( (-d21 ) ( d11 ) )
! = 1/d21 * 1/((d11/d21)*(d22/d21)-1) *
! * ( ( d22/d21 ) ( -1 ) ) =
! ( ( -1 ) ( d11/d21 ) )
! = 1/d21 * 1/(d22*d11-1) * ( ( d11 ) ( -1 ) ) =
! ( ( -1 ) ( d22 ) )
! = 1/d21 * t * ( ( d11 ) ( -1 ) )
! ( ( -1 ) ( d22 ) )
! = d21 * ( ( d11 ) ( -1 ) )
! ( ( -1 ) ( d22 ) )
d21 = w( k-1, kw )
d11 = w( k, kw ) / d21
d22 = w( k-1, kw-1 ) / d21
t = one / ( d11*d22-one )
d21 = t / d21
! update elements in columns a(k-1) and a(k) as
! dot products of rows of ( w(kw-1) w(kw) ) and columns
! of d**(-1)
do j = 1, k - 2
a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) )
a( j, k ) = d21*( d22*w( j, kw )-w( j, kw-1 ) )
end do
end if
! copy d(k) to a
a( k-1, k-1 ) = w( k-1, kw-1 )
a( k-1, k ) = w( k-1, kw )
a( k, k ) = w( k, kw )
end if
end if
! store details of the interchanges in ipiv
if( kstep==1_${ik}$ ) 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
30 continue
! update the upper triangle of a11 (= a(1:k,1:k)) as
! a11 := a11 - u12*d*u12**t = a11 - u12*w**t
! computing blocks of nb columns at a time
do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb
jb = min( nb, k-j+1 )
! update the upper triangle of the diagonal block
do jj = j, j + jb - 1
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, &
kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ )
end do
! update the rectangular superdiagonal block
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k, -one,a( 1_${ik}$, k+1 ), &
lda, w( j, kw+1 ), ldw, one,a( 1_${ik}$, j ), lda )
end do
! put u12 in standard form by partially undoing the interchanges
! in columns k+1:n looping backwards from k+1 to n
j = k + 1_${ik}$
60 continue
! undo the interchanges (if any) of rows jj and jp at each
! step j
! (here, j is a diagonal index)
jj = j
jp = ipiv( j )
if( jp<0_${ik}$ ) then
jp = -jp
! (here, j is a diagonal index)
j = j + 1_${ik}$
end if
! (note: here, j is used to determine row length. length n-j+1
! of the rows to swap back doesn't include diagonal element)
j = j + 1_${ik}$
if( jp/=jj .and. j<=n )call stdlib${ii}$_${ri}$swap( n-j+1, a( jp, j ), lda, a( jj, j ), &
lda )
if( j=nb .and. nbn )go to 90
! copy column k of a to column k of w and update it
call stdlib${ii}$_${ri}$copy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw, &
one, w( k, k ), 1_${ik}$ )
kstep = 1_${ik}$
! determine rows and columns to be interchanged and whether
! a 1-by-1 or 2-by-2 pivot block will be used
absakk = abs( w( k, k ) )
! imax is the row-index of the largest off-diagonal element in
! column k, and colmax is its absolute value.
! determine both colmax and imax.
if( k=alpha*colmax ) then
! no interchange, use 1-by-1 pivot block
kp = k
else
! copy column imax to column k+1 of w and update it
call stdlib${ii}$_${ri}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n-imax+1, a( imax, imax ), 1_${ik}$, w( imax, k+1 ),1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( imax, &
1_${ik}$ ), ldw, one, w( k, k+1 ), 1_${ik}$ )
! jmax is the column-index of the largest off-diagonal
! element in row imax, and rowmax is its absolute value
jmax = k - 1_${ik}$ + stdlib${ii}$_i${ri}$amax( imax-k, w( k, k+1 ), 1_${ik}$ )
rowmax = abs( w( jmax, k+1 ) )
if( imax=alpha*colmax*( colmax / rowmax ) ) then
! no interchange, use 1-by-1 pivot block
kp = k
else if( abs( w( imax, k+1 ) )>=alpha*rowmax ) then
! interchange rows and columns k and imax, use 1-by-1
! pivot block
kp = imax
! copy column k+1 of w to column k of w
call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ )
else
! interchange rows and columns k+1 and imax, use 2-by-2
! pivot block
kp = imax
kstep = 2_${ik}$
end if
end if
! ============================================================
! kk is the column of a where pivoting step stopped
kk = k + kstep - 1_${ik}$
! interchange rows and columns kp and kk.
! updated column kp is already stored in column kk of w.
if( kp/=kk ) then
! copy non-updated column kk to column kp of submatrix a
! at step k. no need to copy element into column k
! (or k and k+1 for 2-by-2 pivot) of a, since these columns
! will be later overwritten.
a( kp, kp ) = a( kk, kk )
call stdlib${ii}$_${ri}$copy( kp-kk-1, a( kk+1, kk ), 1_${ik}$, a( kp, kk+1 ),lda )
if( kp1_${ik}$ )call stdlib${ii}$_${ri}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda )
call stdlib${ii}$_${ri}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw )
end if
if( kstep==1_${ik}$ ) then
! 1-by-1 pivot block d(k): column k of w now holds
! w(k) = l(k)*d(k),
! where l(k) is the k-th column of l
! store subdiag. elements of column l(k)
! and 1-by-1 block d(k) in column k of a.
! (note: diagonal element l(k,k) is a unit element
! and not stored)
! a(k,k) := d(k,k) = w(k,k)
! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k)
call stdlib${ii}$_${ri}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ )
if( k