├── API-doc-FORD-file.md ├── Changelog.md ├── LICENSE ├── Makefile ├── README.md ├── README_CN.md ├── ci └── fpm-deployment.sh ├── doc ├── License.md ├── book.toml ├── index.md ├── media │ ├── Fortran-Fans.png │ └── favicon.png ├── specs │ ├── forlab_io.md │ ├── forlab_linalg.md │ ├── forlab_math.md │ ├── forlab_stats.md │ └── index.md ├── src │ ├── Dev │ │ └── WORKFLOW.md │ ├── Kinds.md │ ├── README.md │ ├── SUMMARY.md │ └── math │ │ ├── README.md │ │ ├── angle.md │ │ └── cross.md └── theme │ └── highlight.js ├── example ├── io │ ├── demo_io_color.f90 │ ├── demo_io_disp.f90 │ ├── demo_io_progress_bar.f90 │ └── demo_io_progress_perc.f90 ├── linalg │ ├── demo_allocation.f90 │ └── demo_linalg_zerosones.f90 ├── math │ ├── demo_math_all_close.f90 │ ├── demo_math_arange.f90 │ ├── demo_math_is_close.f90 │ └── demo_math_signum.f90 └── stats │ ├── demo_stats_randn.f90 │ └── demo_stats_randu.f90 ├── fpm.toml ├── meta-src ├── Makefile ├── common.fypp ├── forlab_.f95 ├── forlab_io.fypp ├── forlab_io_bin.fypp ├── forlab_io_disp_.fypp ├── forlab_io_progress_bar.fypp ├── forlab_io_progress_perc.fypp ├── forlab_io_txt.fypp ├── forlab_linalg.fypp ├── forlab_linalg_cat.fypp ├── forlab_linalg_chol.fypp ├── forlab_linalg_det.fypp ├── forlab_linalg_diag.fypp ├── forlab_linalg_diff.fypp ├── forlab_linalg_eig.fypp ├── forlab_linalg_eye.fypp ├── forlab_linalg_inv.fypp ├── forlab_linalg_linspace.fypp ├── forlab_linalg_lu.fypp ├── forlab_linalg_matpow.fypp ├── forlab_linalg_norm.fypp ├── forlab_linalg_outer.fypp ├── forlab_linalg_qr.fypp ├── forlab_linalg_seq.fypp ├── forlab_linalg_solve.fypp ├── forlab_linalg_svd.fypp ├── forlab_linalg_svdsolve.fypp ├── forlab_linalg_tri.fypp ├── forlab_math.fypp ├── forlab_math_angle.fypp ├── forlab_math_cross.fypp ├── forlab_math_degcir.fypp ├── forlab_math_signum.fypp ├── forlab_sorting.fypp ├── forlab_sorting_argsort.fypp ├── forlab_sorting_sort.fypp ├── forlab_stats.fypp ├── forlab_stats_randn.fypp ├── forlab_stats_randu.fypp ├── forlab_stats_rng.fypp ├── forlab_stats_std.fypp ├── forlab_time.fypp ├── forlab_time_datenum.fypp └── forlab_time_tioc.fypp ├── src ├── forlab_color.f90 ├── forlab_io.f90 ├── forlab_io_bin.f90 ├── forlab_io_color.f90 ├── forlab_io_disp_.f90 ├── forlab_io_progress_bar.f90 ├── forlab_io_progress_perc.f90 ├── forlab_io_read_line.f90 ├── forlab_io_txt.f90 ├── forlab_linalg.f90 ├── forlab_linalg_cat.f90 ├── forlab_linalg_chol.f90 ├── forlab_linalg_det.f90 ├── forlab_linalg_diag.f90 ├── forlab_linalg_diff.f90 ├── forlab_linalg_eig.f90 ├── forlab_linalg_eye.f90 ├── forlab_linalg_inv.f90 ├── forlab_linalg_linspace.f90 ├── forlab_linalg_lu.f90 ├── forlab_linalg_matpow.f90 ├── forlab_linalg_norm.f90 ├── forlab_linalg_outer.f90 ├── forlab_linalg_qr.f90 ├── forlab_linalg_seq.f90 ├── forlab_linalg_solve.f90 ├── forlab_linalg_svd.f90 ├── forlab_linalg_svdsolve.f90 ├── forlab_linalg_tri.f90 ├── forlab_math.f90 ├── forlab_math_all_close.f90 ├── forlab_math_angle.f90 ├── forlab_math_arange.f90 ├── forlab_math_cross.f90 ├── forlab_math_degcir.f90 ├── forlab_math_is_close.f90 ├── forlab_math_signum.f90 ├── forlab_sorting.f90 ├── forlab_sorting_argsort.f90 ├── forlab_sorting_sort.f90 ├── forlab_stats.f90 ├── forlab_stats_randn.f90 ├── forlab_stats_randu.f90 ├── forlab_stats_rng.f90 ├── forlab_stats_std.f90 ├── forlab_time.f90 ├── forlab_time_datenum.f90 └── forlab_time_tioc.f90 └── test ├── checker.f90 ├── io ├── test_io_bin.f90 ├── test_io_color.f90 ├── test_io_disp.f90 ├── test_io_file.f90 └── test_io_read_line.f90 ├── linalg ├── test_linalg_diff.f90 ├── test_linalg_i.f90 ├── test_linalg_linspace.f90 ├── test_linalg_tri.f90 ├── test_linalg_x.f90 └── test_linalg_zerosones.f90 ├── math ├── test_math_all_close.f90 ├── test_math_angle.f90 ├── test_math_arange.f90 ├── test_math_degcir.f90 ├── test_math_is_close.f90 └── test_math_signum.f90 ├── sorting └── test_sorting_sort.f90 ├── stats ├── stats_checker.f90 ├── test_stats_rand.f90 ├── test_stats_randn.f90 ├── test_stats_randu.f90 └── test_stats_var.f90 ├── test.f90 ├── test_math.f90 └── time └── test_time_tioc.f90 /API-doc-FORD-file.md: -------------------------------------------------------------------------------- 1 | --- 2 | project: FORLAB 3 | summary: A opensource package FORLAB v1.0 for (modern) Fortran 4 | src_dir: src/ 5 | output_dir: API-doc 6 | page_dir: doc/ 7 | media_dir: doc/media 8 | display: public 9 | protected 10 | source: true 11 | proc_internals: true 12 | md_extensions: markdown.extensions.toc 13 | graph: true 14 | graph_maxnodes: 250 15 | graph_maxdepth: 5 16 | coloured_edges: true 17 | sort: permission-alpha 18 | extra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html 19 | iso_c_binding:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fC_005fBINDING.html#ISO_005fC_005fBINDING 20 | print_creation_date: true 21 | creation_date: %Y-%m-%d %H:%M %z 22 | project_github: https://github.com/fortran-fans/forlab 23 | project_download: https://github.com/fortran-fans/forlab 24 | favicon: doc/media/favicon.png 25 | license: by-sa 26 | author: FORLAB v1.0 contributors 27 | author_pic: doc/media/Fortran-Fans.png 28 | author_email: zuo.zhihua@qq.com 29 | github: https://github.com/fortran-fans 30 | dbg: true 31 | parallel: 4 32 | --- 33 | 34 | [TOC] 35 | 36 | @warning This API documentation for the fortran-fans/FORLAB v1.0 is a work in progress 37 | 38 | @note 39 | Use the navigation bar at the top of the screen to browse modules, procedures, source files, etc. 40 | The listings near the bottom of the page are incomplete. 41 | 42 | Fortran FORLAB API Documentation 43 | ================================ 44 | 45 | This is the main API documentation landing page generated by [FORD]. 46 | The documentation for comment markup in source code, running [FORD] and the [FORD project file] are all maintained on the [FORD wiki]. 47 | 48 | [FORD]: https://github.com/Fortran-FOSS-Programmers/ford#readme 49 | [FORD wiki]: https://github.com/Fortran-FOSS-Programmers/ford/wiki 50 | [FORD project file]: https://github.com/fortran-fans/forlab/blob/master/API-doc-FORD-file.md 51 | 52 | Goals and Motivation 53 | ==================== 54 | 55 | The Fortran FORLAB v1.0 is a Fortran module that provides a lot of functions for scientific computing mostly inspired by Matlab and Python's module NumPy. 56 | FORLAB is mainly developed by Keurfon Luu. (see [keurfonluu/Forlab](https://github.com/keurfonluu/Forlab)) 57 | 58 | Scope 59 | ===== 60 | 61 | The goal of the FORLAB is to achieve the following general scope: 62 | 63 | * forlab easy-to-use interface 64 | * ford-api-doc 65 | * multi-precision forlab 66 | * benchmarks 67 | 68 | License 69 | ======= 70 | _FORLAB_ is released under the MIT License. 71 | -------------------------------------------------------------------------------- /Changelog.md: -------------------------------------------------------------------------------- 1 | # v1.0.2 2 | 3 | - `forlab_stats` 4 | - redirect `mean`, to `stdlib_stats`. 5 | - `forlab_io` 6 | - add `read_line` and `read_file`. 7 | - `forlab_math` 8 | - redirect `arange/is_close/all_close` to `stdlib_math`. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 FORLAB Contributors 4 | Copyright (c) 2018-2021 Keurfon Luu 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | 24 | - - - 25 | 26 | MIT License 27 | 28 | Copyright (c) 2018 Keurfon Luu 29 | 30 | Permission is hereby granted, free of charge, to any person obtaining a copy 31 | of this software and associated documentation files (the "Software"), to deal 32 | in the Software without restriction, including without limitation the rights 33 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 34 | copies of the Software, and to permit persons to whom the Software is 35 | furnished to do so, subject to the following conditions: 36 | 37 | The above copyright notice and this permission notice shall be included in all 38 | copies or substantial portions of the Software. 39 | 40 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 41 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 42 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 43 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 44 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 45 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 46 | SOFTWARE. 47 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Fortran forlab Makefile, only for developement. 2 | FYPPFLAGS= 3 | 4 | export FYPPFLAGS 5 | 6 | .PHONY: dev clean 7 | 8 | dev: 9 | $(MAKE) -f Makefile --directory=meta-src 10 | 11 | clean: 12 | $(MAKE) -f Makefile clean --directory=meta-src -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # FORLAB 2 | 3 | [![Actions Status](https://github.com/fortran-fans/forlab/workflows/fpm/badge.svg)](https://github.com/fortran-fans/forlab/actions) 4 | 5 | FORLAB is a Fortran module that provides some functions for scientific computing. 6 | It's more like a small **toolbox**. 7 | FORLAB uses [stdlib](https://github.com/fortran-lang/stdlib) as an upstream package. FORLAB hopes to be a small scaffolding tool. Compared with [stdlib](https://github.com/fortran-lang/stdlib), FORLAB is less formal. 8 | 9 | | | | 10 | |:-:|---| 11 | | **Version:** | 1.0.2 | 12 | | **Author:** | FORLAB Contributors | 13 | | **Web site:** | https://github.com/fortran-fans/forlab | 14 | | **API-Doc Web site:** | https://zoziha.github.io/forlab-API-doc/ | 15 | | **Copyright:** | _This document_ has been placed in the public domain. | 16 | | **License:** | _FORLAB_ is released under the MIT License. | 17 | 18 | ## Getting Started ([中文文档](./README_CN.md)) 19 | ### Get the code 20 | 21 | ```bash 22 | git clone https://github.com/fortran-fans/forlab.git 23 | cd forlab 24 | ``` 25 | 26 | ### Supported Compilers 27 | 28 | The following combinations are tested on the default branch of `forlab`: 29 | |Name|Vesrion|Platform|Architecture| 30 | |---|---|---|---| 31 | |GCC Fortran(MSYS2)|10|Windows 10|x86_64| 32 | |GCC Fortran|10|Ubuntu|x86_64| 33 | |GCC Fortran|10|MacOS|x86_64| 34 | 35 | ### Build with [fortran-lang/fpm](https://github.com/fortran-lang/fpm) 36 | Fortran Package Manager (fpm) is a great package manager and build system for Fortran. 37 | You can build using provided `fpm.toml`: 38 | ```bash 39 | fpm build 40 | fpm test --list 41 | fpm test 42 | ``` 43 | 44 | To use `forlab` within your `fpm` project, add the following to `fpm.toml` file: 45 | ```toml 46 | [dependencies] # or [dev-dependencies] for tests. 47 | forlab = { git="https://github.com/fortran-fans/forlab.git", branch="forlab-fpm" } 48 | ``` 49 | 50 | ## API-Doc 51 | 52 | ```bash 53 | ford API-doc-FORD-file.md # todo 54 | ``` 55 | see [forlab-API-doc](https://fortran-fans.github.io/forlab/page/specs/index.html). 56 | 57 | Some examples are prepared in the `./example` folder, and you can use `fpm` to run them. 58 | ```sh 59 | fpm run --example --list 60 | fpm run --example 61 | ``` 62 | 63 | ## More informations 64 | 65 | ### Links 66 | 1. [keurfonluu/Forlab](https://github.com/keurfonluu/Forlab) 67 | Forlab is mainly developed by Keurfon Luu originally. 68 | 2. [stdlib](https://github.com/fortran-lang/stdlib) 69 | Fortran standard library. 70 | 3. Fortran [Generics](https://github.com/j3-fortran/generics) 71 | 72 | ### Fypp 73 | The original intention of developing the multi-precision library(`forlab`) is 74 | to facilitate the user to switch the program accuracy requirements in a timely manner, 75 | which is challenging. We use `fypp` to build a multi-precision `forlab`. 76 | I have to say that `fypp` has helped us a lot. I learned that the use of code 77 | to generate code is called **meta-programming**. I also think that metaprogramming 78 | has great potential, especially for some low-level polymorphic functions and 79 | improving the dynamics of statically compiled languages, which is very helpful. 80 | I hope that `fypp` will get better and better, and that `fortran` will natively 81 | support `meta-programming` technology in the future. 82 | 83 | ### The problems we encountered 84 | 1. The adaptability of `fortran` metaprogramming ability is not strong; 85 | 2. Modular development `module` and setting `submodule` should best be **combined** effectively to improve development efficiency. 86 | 3. We don't want `forlab` to increase its **volume** unlimitedly. We hope that 87 | it can be used in areas where it can achieve value, such as rapid development 88 | of fortran automation applets. So we will keep the forlab lightweight, and 89 | update and repair it from time to time. 90 | 4. Fpm currently has some problems and pain points when compiling the program (But we are very optimistic about the potential of `fpm`): 91 | + Slow compilation speed. (Improvements in this PR: [optimize file listing](https://github.com/fortran-lang/fpm/pull/507)) 92 | + Cannot manage and distribute `fpm` packages well now. 93 | 5. Fortran [Generics](https://github.com/j3-fortran/generics): Due to the lack of more complete generics, certain functions such as multiple precision and multiple array dimensions cannot be implemented now. -------------------------------------------------------------------------------- /README_CN.md: -------------------------------------------------------------------------------- 1 | # FORLAB 2 | 3 | [![Actions Status](https://github.com/fortran-fans/forlab/workflows/fpm/badge.svg)](https://github.com/fortran-fans/forlab/actions) 4 | 5 | FORLAB是一个为科学计算提高一些常用函数的Fortran代码库。它更像是一个小工具箱。 6 | 7 | FORLAB使用stdlib作为上游包，相比于stdlib，FORLAB是非正式的，它希望成为一个小的脚手架工具。 8 | 9 | 10 | | 项目 | 描述 | 11 | |:-:|---| 12 | | **版本:** | 1.0.1 | 13 | | **作者:** | FORLAB 贡献者 | 14 | | **源码网页:** | https://github.com/fortran-fans/forlab | 15 | | **API-Doc网页:** | https://fortran-fans.github.io/forlab/ | 16 | | **许可证:** | _ORLAB在MIT开源许可证下发行. | 17 | 18 | ## 开始([English README](README.md)) 19 | 20 | ### 获取代码 21 | 22 | ```bash 23 | git clone https://github.com/fortran-fans/forlab.git 24 | cd forlab 25 | ``` 26 | 27 | ### 支持的编译器 28 | 29 | 以下编译器在FORLAB的分支上经过测试： 30 | |名字|版本|平台|CPU架构| 31 | |---|---|---|---| 32 | |GCC Fortran(MSYS2)|10|Windows 10|x86_64| 33 | |GCC Fortran|10|Ubuntu|x86_64| 34 | |GCC Fortran|10|MacOS|x86_64| 35 | 36 | ### 使用[fortran-lang/fpm](https://github.com/fortran-lang/fpm)构建 37 | 38 | Fortran包管理器(FPM)是一个为Fortran而生的包管理器和构建系统。 39 | 你可以使用提供的`fpm.toml`来构建FORLAB： 40 | 41 | ```bash 42 | fpm build 43 | fpm test --list 44 | fpm test 45 | ``` 46 | 47 | 可以在你的FPM工程的`fpm.toml`文件中添加以下的语句，以使用FORLAB： 48 | 49 | ```toml 50 | [dependencies] # or [dev-dependencies] for tests. 51 | forlab = { git="https://github.com/fortran-fans/forlab.git", branch="forlab-fpm" } 52 | ``` 53 | 54 | ## API文档 55 | 56 | ```bash 57 | ford API-doc-FORD-file.md # todo 58 | cd doc && mdbook build 59 | ``` 60 | see [forlab-API-doc](https://fortran-fans.github.io/forlab/). 61 | 62 | 有一些API使用的例子被放置在了`example`文件夹下，你可以使用FPM来运行它们： 63 | 64 | ```sh 65 | fpm run --example --list 66 | fpm run --example 67 | ``` 68 | 69 | ## 其它信息 70 | 71 | ### Links 72 | 1. [keurfonluu/Forlab](https://github.com/keurfonluu/Forlab) 73 | FORLAB原本是由Keurfon Luu主要开发！ 74 | 2. [stdlib](https://github.com/fortran-lang/stdlib) 75 | Fortran standard library. 76 | 3. Fortran [Generics](https://github.com/j3-fortran/generics) 77 | 78 | ### Fypp 79 | 80 | The original intention of developing the multi-precision library(`forlab`) is 81 | to facilitate the user to switch the program accuracy requirements in a timely manner, 82 | which is challenging. We use `fypp` to build a multi-precision `forlab`. 83 | I have to say that `fypp` has helped us a lot. I learned that the use of code 84 | to generate code is called **meta-programming**. I also think that metaprogramming 85 | has great potential, especially for some low-level polymorphic functions and 86 | improving the dynamics of statically compiled languages, which is very helpful. 87 | I hope that `fypp` will get better and better, and that `fortran` will natively 88 | support `meta-programming` technology in the future. 89 | 90 | ### The problems we encountered 91 | 1. The adaptability of `fortran` metaprogramming ability is not strong; 92 | 2. Modular development `module` and setting `submodule` should best be **combined** effectively to improve development efficiency. 93 | 3. We don't want `forlab` to increase its **volume** unlimitedly. We hope that 94 | it can be used in areas where it can achieve value, such as rapid development 95 | of fortran automation applets. So we will keep the forlab lightweight, and 96 | update and repair it from time to time. 97 | 4. Fpm currently has some problems and pain points when compiling the program (But we are very optimistic about the potential of `fpm`): 98 | + Slow compilation speed. (Improvements in this PR: [optimize file listing](https://github.com/fortran-lang/fpm/pull/507)) 99 | + Cannot manage and distribute `fpm` packages well now. 100 | 5. Fortran [Generics](https://github.com/j3-fortran/generics): Due to the lack of more complete generics, certain functions such as multiple precision and multiple array dimensions cannot be implemented now. -------------------------------------------------------------------------------- /ci/fpm-deployment.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -ex 4 | 5 | # Target directory to deploy stdlib to 6 | destdir="${DESTDIR:-forlab-fpm}" 7 | 8 | # Additional files to include 9 | include=( 10 | "fpm.toml" 11 | "LICENSE" 12 | "README.md" 13 | ) 14 | 15 | mkdir -p "$destdir/src" "$destdir/test" 16 | 17 | # Collect stdlib source files 18 | cp src/* "$destdir/src/" 19 | cp -r test/* "$destdir/test/" 20 | 21 | # Include additional files 22 | cp "${include[@]}" "$destdir/" 23 | 24 | # List stdlib-fpm package contents 25 | ls -R "$destdir" -------------------------------------------------------------------------------- /doc/License.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: Fortran FORLAB License (MIT) 3 | --- 4 | 5 | {!LICENSE!} 6 | -------------------------------------------------------------------------------- /doc/book.toml: -------------------------------------------------------------------------------- 1 | [book] 2 | 3 | title = "FORLAB API Documentation" 4 | authors = ["zoziha"] 5 | language = "zh" 6 | src = "src" -------------------------------------------------------------------------------- /doc/index.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: Contributing and specs 3 | --- 4 | 5 | @warning 6 | This page is currently under construction! 7 | 8 | @todo 9 | Improve the title of this FORD "pages" section, and 10 | improve the organization of pages 11 | to separate end-user, high-level documentation and examples from developer documentation and specs. 12 | -------------------------------------------------------------------------------- /doc/media/Fortran-Fans.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fortran-fans/forlab/1acee0a68a703dc0b9668167494b9cb8ee71264d/doc/media/Fortran-Fans.png -------------------------------------------------------------------------------- /doc/media/favicon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fortran-fans/forlab/1acee0a68a703dc0b9668167494b9cb8ee71264d/doc/media/favicon.png -------------------------------------------------------------------------------- /doc/specs/forlab_linalg.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: LINALG 3 | --- 4 | 5 | # LINALG 6 | 7 | [TOC] 8 | 9 | ## `diff` - diff computes differences of arrays. 10 | 11 | ### Status 12 | 13 | Experimental 14 | 15 | ### Class 16 | 17 | Pure function. 18 | 19 | ### Description 20 | 21 | y = diff(x) returns differences between adjacent elements of vector x. 22 | y = diff(x, n) returns the nth difference by applying the diff(x) operator recursively n times. 23 | B = diff(A) returns differences between adjacent elements of array A along the first dimension. 24 | B = diff(A, n) returns the nth difference by applying the diff(A) operator recursively n times. 25 | B = diff(A, dim) returns differences between adjacent elements of array A along the dimension given by dim. 26 | B = diff(A, n, dim) returns the nth difference along the dimension given by dim by applying the diff(A, dim) operator recursively n times. 27 | 28 | 29 | ### Syntax 30 | 31 | For vector: 32 | `result = [[forlab_linalg(module):diff(interface)]](x [, n])` 33 | 34 | For matrix: 35 | `result = [[forlab_linalg(module):diff(interface)]](A [, n, dim])` 36 | 37 | ### Arguments 38 | 39 | `x`: Shall be a `real` type of verctor. 40 | `A`: Shall be a `real` type of matrix. 41 | 42 | `n` (optional): Shall be a `integer` type. 43 | `dim` (optional): Shall be a `integer` type. 44 | 45 | 46 | ### Return value 47 | 48 | Return differences between adjacent elements of vector `x` or matrix `A`. 49 | 50 | ### Example 51 | 52 | ```fortran 53 | program test_linalg_diff 54 | use forlab_linalg, only: diff 55 | use forlab_linalg, only: linspace 56 | use forlab_io, only: disp 57 | 58 | real :: x(10) 59 | 60 | call linspace(x, 0.0, 9.0) 61 | call disp(x, "linspace(x) : ") 62 | call disp(diff(x), "test_linalg_diff : ") 63 | 64 | 65 | end program test_linalg_diff 66 | ``` 67 | 68 | ## `zeros/ones` 69 | 70 | ### Description 71 | 72 | `zeros` creates a rank-1 or rank-2 `array` of the given shape, filled completely with `0` `integer` type values. 73 | `ones` creates a rank-1 or rank-2 `array` of the given shape, filled completely with `1` `integer` type values. 74 | 75 | #### Warning 76 | 77 | It is not recommended to use the `zeros/ones` function, it is recommended to use `allocate(array(dim1, dim2, ..), source=0.0/1.0)`. 78 | 79 | ### Status 80 | 81 | Experimental 82 | 83 | ### Class 84 | 85 | Pure function. 86 | 87 | ### Syntax 88 | 89 | For rank-1 array: 90 | `result = [[forlab_linalg(module):zeros(interface)]](dim)` 91 | `result = [[forlab_linalg(module):ones(interface)]](dim)` 92 | 93 | For rank-2 array: 94 | `result = [[forlab_linalg(module):zeros(interface)]](dim1, dim2)` 95 | `result = [[forlab_linalg(module):ones(interface)]](dim1, dim2)` 96 | 97 | 98 | ### Arguments 99 | 100 | `dim/dim1`: Shall be an `integer` type. 101 | This is an `intent(in)` argument. 102 | 103 | `dim2`: Shall be an `integer` type. 104 | This is an `intent(in)` argument. 105 | 106 | ### Return value 107 | 108 | Returns a rank-1 or rank-2 `array` of the given shape, filled completely with either `0` or `1` `integer` type values. 109 | 110 | #### Warning 111 | 112 | Since the result of `ones` is of `integer` type, one should be careful about using it in arithmetic expressions. For example: 113 | ```fortran 114 | real :: A(:,:) 115 | !> Be careful 116 | A = ones(2,2)/2 !! A = 1/2 = 0.0 117 | !> Recommend 118 | A = ones(2,2)/2.0 !! A = 1/2.0 = 0.5 119 | ``` 120 | 121 | ### Example 122 | 123 | ```fortran 124 | program demo_linalg_zerosones 125 | use forlab_linalg, only: zeros, ones 126 | use forlab_io, only: disp 127 | 128 | real, allocatable :: zero(:, :), one(:, :) 129 | real, allocatable :: array(:, :) 130 | 131 | zero = zeros(1, 2) 132 | one = ones (2, 1) 133 | 134 | call disp(zero, "zeros: ") 135 | call disp(one , "ones : ") 136 | 137 | call disp(ones(2, 2)/2, "!attention: `ones(2, 2)/2` is like `1/2 == 0`") 138 | 139 | array = zeros(2, 2) 140 | call disp(array, "array with zeros: ") 141 | 142 | array = ones (2, 2) 143 | call disp(array, "array with ones :") 144 | 145 | end program demo_linalg_zerosones 146 | ``` -------------------------------------------------------------------------------- /doc/specs/forlab_stats.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: STATS 3 | --- 4 | 5 | # STATS 6 | 7 | #### Notes 8 | 9 | In daily use, vectors and matrices are more practical than higher-order arrays, 10 | and Fortran does not support array generics, we can use `reshape` to reshape vectors into higher-order arrays. 11 | 12 | ```fortran 13 | real :: x(2,3,4) 14 | x = reshape(randn(mean=0.0, std=1.0, ndim=2*3*4), [2,3,4]) 15 | ``` 16 | 17 | [TOC] 18 | 19 | ### `randu` 20 | 21 | #### Description 22 | 23 | Generate an uniformly distributed data scalar or vector. 24 | 25 | #### Status 26 | 27 | Experimental. 28 | 29 | #### Class 30 | 31 | Impure function. 32 | 33 | #### Syntax 34 | 35 | `random = [[forlab_stats(module):randu(interface)]](start, end [, ndim])` 36 | 37 | #### Arguments 38 | 39 | `random/start/end` should keep the same type and kind. 40 | 41 | `start`: Shall be an `integer/real` scalar. 42 | This argument is `intenet(in)`. 43 | 44 | `end`: Shall be an `integer/real` scalar. 45 | This argument is `inetent(in)`. 46 | 47 | `ndim`: Shall be an `integer` scalar. 48 | This argument is `intent(in)` and `optional`. 49 | 50 | #### Result value 51 | 52 | Returns an `integer/real` scalar or rank-1 array. 53 | 54 | #### Example 55 | 56 | ```fortran 57 | program demo_stats_randu 58 | 59 | use forlab_stats, only: randu 60 | 61 | print *, "running `demo_stats_randu`.." 62 | 63 | print *, randu(start=1, end=2) 64 | print *, randu(start=1.0, end=2.0, ndim=3) 65 | print *, reshape(randu(1.0, 2.0, 2*2), [2,2]) 66 | 67 | !> Possible output: 68 | 69 | !! 2 70 | !! 1.65676987 1.11625218 1.03502560 71 | !! 1.74973476 1.82997108 1.77998054 1.14384007 72 | 73 | end program demo_stats_randu 74 | ``` 75 | 76 | ### `randn` 77 | 78 | #### Description 79 | 80 | Generate a normal distributed data scalar or vector. 81 | 82 | #### Status 83 | 84 | Experimental. 85 | 86 | #### Class 87 | 88 | Impure function. 89 | 90 | #### Syntax 91 | 92 | `random = [[forlab_stats(module):randn(interface)]](mean, std [, ndim])` 93 | 94 | #### Arguments 95 | 96 | `random/mean/std` should keep the same type and kind. 97 | 98 | `mean`: Shall be an `integer/real` scalar. 99 | This argument is `intenet(in)`. 100 | 101 | `std`: Shall be an `integer/real` scalar. 102 | This argument is `inetent(in)`. 103 | 104 | `ndim`: Shall be an `integer` scalar. 105 | This argument is `intent(in)` and `optional`. 106 | 107 | #### Result value 108 | 109 | Returns an `integer/real` scalar or rank-1 array. 110 | 111 | #### Example 112 | 113 | ```fortran 114 | program demo_stats_randn 115 | 116 | use forlab_stats, only: randn 117 | 118 | print *, "running `demo_stats_randn`.." 119 | 120 | print *, randn(mean=0.0, std=2.0) 121 | print *, randn(mean=0.0, std=2.0, ndim=3) 122 | print *, reshape(randn(0.0, 2.0, 2*2), [2,2]) 123 | 124 | !> Chi-square distribution of 3 degrees of freedom 125 | print *, sum(randn(mean=0.0, std=1.0, ndim=3)**2) 126 | print *, sum(reshape(randn(mean=0.0, std=1.0, ndim=5*3), [5, 3])**2, dim=2) 127 | 128 | !> Possible output: 129 | 130 | !! -0.387298465 131 | !! -1.37615824 -0.529266298 5.43095016 132 | !! -1.35311902 1.81701779 0.772518456 -0.269844353 133 | 134 | !! 9.45483303 135 | !! 0.962645471 0.698421597 0.687875450 4.75956964 1.71025097 136 | 137 | end program demo_stats_randn 138 | ``` -------------------------------------------------------------------------------- /doc/specs/index.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: Specifications (specs) 3 | --- 4 | 5 | # Fortran forlab Specifications (specs) 6 | 7 | [TOC] 8 | 9 | ## Experimental Features & Modules 10 | 11 | - [IO](./forlab_io.html) - Input/output helper & convenience 12 | - [math](./forlab_math.html) - Math functions 13 | - [linalg](./forlab_linalg.html) - Linear Algebra 14 | - [stats](./forlab_stats.html) - Descriptive Statistics 15 | 16 | ## Released/Stable Features & Modules 17 | 18 | - (None yet) 19 | -------------------------------------------------------------------------------- /doc/src/Dev/WORKFLOW.md: -------------------------------------------------------------------------------- 1 | # WORKFLOW 2 | [TOC] 3 | 4 | ## Workflow tools 5 | 1. vs code with bash terminal 6 | 2. fypp 7 | 3. gnu make 8 | 4. fpm 9 | 5. git 10 | 6. ford 11 | 12 | ### ford help 13 | 14 | #### markdown syntax 15 | 16 | [ford markdown](https://daringfireball.net/projects/markdown/basics) 17 | 18 | ## Add fypp files 19 | 20 | ### fypp -> f90 -> fpm 21 | 1. make: make src/fypp/*.fypp -> src/f90 22 | 2. fpm build: f90 -> *.obj 23 | bash command: 24 | ```bash 25 | make # or `make dev` 26 | fpm test 27 | --- 28 | make&&fpm test 29 | --- 30 | make&&fpm test > test.txt 31 | --- 32 | make&&fpm test --flag '-g' > test.txt 33 | --- 34 | time make&&fpm test --flag '-g' > test.txt 35 | --- 36 | \time -v make&&fpm test --flag ' ' > test.txt 37 | ``` 38 | ### Development sequence 39 | 1. idea & discussion. 40 | 2. and add to `ChangeLog.md`, add _idea_.fypp 41 | 3. use `submodule` snytax to complete _idea_.fypp 42 | 4. add interface to `forlab.fypp` 43 | 5. write a test program, `make && fpm test` 44 | 6. if successed, copy `test.f90` to `example` dir, and modify its name to `idea_example_name.f90`. 45 | 46 | last, don't forget log your work has been done in `ChangeLog.md`✔. 47 | > Please refer to [gnu changelog](https://www.gnu.org/prep/standards/html_node/Change-Logs.html) for the format of `ChangeLog.md`. 48 | 49 | ### fypp example 50 | #### submodule.fypp example 51 | ```fortran 52 | !! brief comments for this file 53 | 54 | submodule (forlab) forlab_zeros 55 | !! comments for this submodule 56 | !!([Interface](../interface/zeros.html)) 57 | 58 | ... 59 | 60 | contains 61 | end submodule 62 | 63 | ``` 64 | #### forlab.fypp example 65 | ```fortran 66 | module forlab 67 | interface zeros 68 | !! brief comments for this function/subroutine interface 69 | !!([Specification](../module/forlab_zeros.html)) 70 | 71 | ... 72 | 73 | end interface 74 | 75 | end module 76 | 77 | ``` 78 | 79 | 80 | ### Push your work 81 | 1. git add your work. 82 | 2. git push to origin repo. 83 | 3. make a PR. 84 | 85 | You can make a PR with more than one work, it depend on youself😉. 86 | 87 | ### A good thing 88 | If you are not sure how to write some grammar, you can log on to the website: 89 | https://www.onlinegdb.com/online_fortran_compiler# 90 | 91 | ## Reference packages 92 | Refer to other libraries, so that we can quickly know what else we can do 93 | for forlab and make it more perfect. 94 | 1. [Armadillo](http://arma.sourceforge.net/docs.html): 95 | C++ library for linear algebra & scientific computing. 96 | 2. 97 | -------------------------------------------------------------------------------- /doc/src/Kinds.md: -------------------------------------------------------------------------------- 1 | # 精度说明 2 | 3 | 目前forlab支持： 4 | 5 | - 整型：int8, int16, int32, int64 6 | - 浮点型：real32, real64 (real128由于上游stdlib暂时取消了) -------------------------------------------------------------------------------- /doc/src/README.md: -------------------------------------------------------------------------------- 1 | {{#include ../../README.md}} 2 | -------------------------------------------------------------------------------- /doc/src/SUMMARY.md: -------------------------------------------------------------------------------- 1 | # SUMMARY 2 | 3 | - [About](README.md) 4 | 5 | - [精度说明](Kinds.md) 6 | 7 | - [math](math/README.md) 8 | - [cross](math/cross.md) 9 | - [angle](math/angle.md) -------------------------------------------------------------------------------- /doc/src/math/README.md: -------------------------------------------------------------------------------- 1 | # Math 2 | 3 | Forlab Math module. -------------------------------------------------------------------------------- /doc/src/math/angle.md: -------------------------------------------------------------------------------- 1 | # `angle` 2 | 3 | ## Description 4 | 5 | Solve for the argument of a complex number, or the angle between two three-dimensional vectors. 6 | 7 | ## Syntax 8 | 9 | ```fortran 10 | angle = angle(X, Y) 11 | arg = angle(z) 12 | ``` 13 | 14 | ## Status 15 | 16 | Experimental. 17 | 18 | ## Class 19 | 20 | Pure function. 21 | 22 | ## Arguments 23 | 24 | `X`: Shall be a `real` and `dimension(3)` array. 25 | This argument is `intent(in)`. 26 | 27 | `Y`: Shall be a `real` and `dimension(3)` array. 28 | This argument is `intent(in)`. 29 | 30 | `z`: Shall be a `complex` scalar. 31 | This argument is `intent(in)`. 32 | 33 | Note: All `real/integer` arguments must have same `kind`. 34 | 35 | ## Result value 36 | 37 | Returns a `real` scalar. 38 | 39 | ## Example 40 | 41 | ```fortran 42 | program demo_math_angle 43 | use, intrinsic :: iso_fortran_env, only: int8 44 | use forlab_math, only: angle 45 | real, dimesion(3) :: x, y 46 | complex :: z = cmplx(3.0, 4.0) 47 | 48 | x = 1_int8 ; y = 2_int8 49 | print *, angle(x, y) !! 0.0 50 | print *, angle(z) !! 0.927295208 51 | 52 | end program demo_math_angle 53 | ``` 54 | 55 | ## Source(incomplete) 56 | 57 | ```fortran 58 | {{#include ../../../src/forlab_math_angle.f90}} 59 | ``` -------------------------------------------------------------------------------- /doc/src/math/cross.md: -------------------------------------------------------------------------------- 1 | # `cross` 2 | 3 | ## Description 4 | 5 | Cross product. 6 | 7 | ## Syntax 8 | 9 | ```fortran 10 | z = cross(x, y) 11 | z = x .c. y 12 | ``` 13 | 14 | ## Status 15 | 16 | Experimental. 17 | 18 | ## Class 19 | 20 | Pure function. 21 | 22 | ## Arguments 23 | 24 | `x`: Shall be a `real/integer` and `dimension(3)` array. 25 | This argument is `intent(in)`. 26 | 27 | `y`: Shall be a `real/integer` and `dimension(3)` array. 28 | This argument is `intent(in)`. 29 | 30 | Note: All `real/integer` arguments must have same `kind`. 31 | 32 | ## Result value 33 | 34 | Returns a `real/integer` and `dimension(3)` array. 35 | 36 | ## Example 37 | 38 | ```fortran 39 | program demo_math_cross 40 | use, intrinsic :: iso_fortran_env, only: int8 41 | use forlab_math, only: cross, operator(.c.) 42 | real, dimesion(3) :: x, y 43 | 44 | x = 1_int8 ; y = 2_int8 45 | print *, x.c.y !! [0.0, 0.0, 0.0] 46 | print *, cross(x,y) !! [0.0, 0.0, 0.0] 47 | 48 | end program demo_math_cross 49 | ``` 50 | 51 | ## Source 52 | 53 | ```fortran 54 | {{#include ../../../src/forlab_math_cross.f90}} 55 | ``` -------------------------------------------------------------------------------- /example/io/demo_io_color.f90: -------------------------------------------------------------------------------- 1 | program demo_io_color 2 | 3 | use forlab_io, only: color 4 | use forlab_color, only: red, green 5 | character(len=*), parameter :: char = "It is a Fortran color: " 6 | 7 | call color(green) 8 | print *, char // 'green.' 9 | 10 | print *, red // char // 'red.' 11 | 12 | call color() 13 | print *, char // "default." 14 | 15 | end program demo_io_color -------------------------------------------------------------------------------- /example/io/demo_io_disp.f90: -------------------------------------------------------------------------------- 1 | program demo_io_disp 2 | 3 | use forlab_io, only: disp 4 | use stdlib_io, only: open 5 | 6 | real(8) :: r(2, 3) 7 | complex :: c(2, 3), c_3d(2, 100, 20) 8 | integer :: i(2, 3) 9 | logical :: l(10, 10) 10 | 11 | r = 1.; c = 1.; c_3d = 2.; i = 1; l = .true. 12 | r(1, 1) = -1.e-11 13 | r(1, 2) = -1.e10 14 | c(2, 2) = (-1.e10, -1.e10) 15 | c_3d(1, 3, 1) = (1000, 0.001) 16 | c_3d(1, 3, 2) = (1.e4, 100.) 17 | 18 | call disp('string', header='disp(string):') 19 | call disp('It is a note.') 20 | call disp() 21 | call disp(r, header='disp(r):') 22 | call disp(r(1, :), header='disp(r(1,:))') 23 | call disp(c, header='disp(c):') 24 | call disp(i, header='disp(i):') 25 | call disp(l, header='disp(l):', brief=.true.) 26 | call disp(c_3d(:, :, 3), header='disp(c_3d(:,:,3)):', brief=.true.) 27 | call disp(c_3d(2, :, :), header='disp(c_3d(2,:,:)):', brief=.true.) 28 | 29 | j = open ("DP.txt", "w+") 30 | call disp(c_3d(1,:,:), header="test_disp_to_unit: ", unit=j) 31 | close (j) 32 | 33 | end program demo_io_disp 34 | -------------------------------------------------------------------------------- /example/io/demo_io_progress_bar.f90: -------------------------------------------------------------------------------- 1 | program demo_io_progress_bar 2 | 3 | use forlab_io, only: progress_bar 4 | use forlab_stats, only: randu 5 | 6 | do i = 0, 100, 10 7 | call progress_bar(i, 100) 8 | call sleep(randu(1, 2)) 9 | end do 10 | 11 | write(*,"(3A)",advance="no") char(13), "Calculation Done!", repeat(" ", 55) 12 | 13 | end program demo_io_progress_bar 14 | -------------------------------------------------------------------------------- /example/io/demo_io_progress_perc.f90: -------------------------------------------------------------------------------- 1 | program demo_io_progress_perc 2 | 3 | use forlab_io, only: progress_perc 4 | use forlab_stats, only: randu 5 | 6 | do i = 0, 100, 10 7 | call progress_perc(i, 100, ">>") 8 | call sleep(randu(1, 3)) 9 | end do 10 | 11 | end program demo_io_progress_perc -------------------------------------------------------------------------------- /example/linalg/demo_allocation.f90: -------------------------------------------------------------------------------- 1 | !> Compare with `demo_linalg_zerosones` 2 | !> It is not recommended to use the `zeros/ones` function, 3 | !> it is recommended to use `allocate(array(dim1, dim2, ..), source=0.0/1.0)`. 4 | program demo_allocation 5 | use forlab_io, only: disp 6 | 7 | real, allocatable :: zero(:, :), one(:, :) 8 | real, allocatable :: array(:, :) 9 | 10 | 11 | allocate(zero(1, 2), source=0.0) 12 | allocate(one (1, 2), source=1.0) 13 | 14 | call disp(zero, "zeros: ") 15 | call disp(one , "ones : ") 16 | 17 | allocate(array(2, 2), source=0.0) 18 | call disp(array, "array with zeros: ") 19 | 20 | deallocate(array) 21 | allocate(array(2, 2), source=1.0) 22 | call disp(array, "array with ones : ") 23 | 24 | end program demo_allocation -------------------------------------------------------------------------------- /example/linalg/demo_linalg_zerosones.f90: -------------------------------------------------------------------------------- 1 | !> It is not recommended to use the `zeros/ones` function, 2 | !> it is recommended to use `allocate(array(dim1, dim2, ..), source=0.0/1.0)`. 3 | program demo_linalg_zerosones 4 | use forlab_linalg, only: zeros, ones 5 | use forlab_io, only: disp 6 | 7 | real, allocatable :: zero(:, :), one(:, :) 8 | real, allocatable :: array(:, :) 9 | 10 | zero = zeros(1, 2) 11 | one = ones (2, 1) 12 | 13 | call disp(zero, "zeros: ") 14 | call disp(one , "ones : ") 15 | 16 | call disp(ones(2, 2)/2, "!attention: `ones(2, 2)/2` is like `1/2 == 0`") 17 | 18 | array = zeros(2, 2) 19 | call disp(array, "array with zeros: ") 20 | 21 | array = ones (2, 2) 22 | call disp(array, "array with ones :") 23 | 24 | end program demo_linalg_zerosones -------------------------------------------------------------------------------- /example/math/demo_math_all_close.f90: -------------------------------------------------------------------------------- 1 | program demo_math_all_close 2 | use forlab_math, only: all_close 3 | use stdlib_error, only: check 4 | real :: x(2) = [1, 2], random(4, 4) 5 | complex :: z(4, 4) 6 | 7 | call check(all_close(x, [2.0, 2.0], rel_tol=1.0e-6, abs_tol=1.0e-3), & 8 | msg="all_close(x, [2.0, 2.0]) failed.", warn=.true.) 9 | !! all_close(x, [2.0, 2.0]) failed. 10 | call random_number(random(4, 4)) 11 | z = 1.0 12 | print *, all_close(z+1.0e-11*random, z) !! T 13 | 14 | end program demo_math_all_close -------------------------------------------------------------------------------- /example/math/demo_math_arange.f90: -------------------------------------------------------------------------------- 1 | program demo_math_arange 2 | use forlab_math, only: arange 3 | use forlab_io, only: disp 4 | 5 | call disp(arange(3)) !! [1,2,3] 6 | call disp(arange(-1)) !! [1,0,-1] 7 | call disp(arange(0,2)) !! [0,1,2] 8 | call disp(arange(1,-1)) !! [1,0,-1] 9 | call disp(arange(0, 2, 2)) !! [0,2] 10 | 11 | call disp(arange(3.0)) !! [1.0,2.0,3.0] 12 | call disp(arange(0.0,5.0)) !! [0.0,1.0,2.0,3.0,4.0,5.0] 13 | call disp(arange(0.0,6.0,2.5)) !! [0.0,2.5,5.0] 14 | 15 | call disp((1.0,1.0)*arange(3)) !! [(1.0,1.0),(2.0,2.0),[3.0,3.0]] 16 | 17 | call disp(arange(0.0,2.0,-2.0)) !! [0.0,2.0]. Not recommended: `step` argument is negative! 18 | call disp(arange(0.0,2.0,0.0)) !! [0.0,1.0,2.0]. Not recommended: `step` argument is zero! 19 | 20 | end program demo_math_arange -------------------------------------------------------------------------------- /example/math/demo_math_is_close.f90: -------------------------------------------------------------------------------- 1 | program demo_math_is_close 2 | use forlab_math, only: is_close 3 | use stdlib_error, only: check 4 | real :: x(2) = [1, 2] 5 | print *, is_close(x,[real :: 1, 2.1]) !! [T, F] 6 | print *, is_close(2.0, 2.1, abs_tol=0.1) !! T 7 | call check(all(is_close(x, [2.0, 2.0])), msg="all(is_close(x, [2.0, 2.0])) failed.", warn=.true.) 8 | !! all(is_close(x, [2.0, 2.0])) failed. 9 | end program demo_math_is_close -------------------------------------------------------------------------------- /example/math/demo_math_signum.f90: -------------------------------------------------------------------------------- 1 | !> fpm run --example math_signum 2 | program demo_math_signum 3 | use forlab_math, only: signum 4 | 5 | print *, signum(1 - 2) 6 | print *, signum([0.0, 2.1]) 7 | print *, signum((1.0, -2.0)) 8 | 9 | !> -1 10 | !> 0.00000000 1.00000000 11 | !> (0.447213590,-0.894427180) 12 | 13 | end program demo_math_signum 14 | -------------------------------------------------------------------------------- /example/stats/demo_stats_randn.f90: -------------------------------------------------------------------------------- 1 | program demo_stats_randn 2 | 3 | use forlab_stats, only: randn 4 | 5 | print *, "running `demo_stats_randn`.." 6 | 7 | print *, randn(mean=0.0, std=2.0) 8 | print *, randn(mean=0.0, std=2.0, ndim=3) 9 | print *, reshape(randn(0.0, 2.0, 2*2), [2,2]) 10 | 11 | !> Chi-square distribution of 3 degrees of freedom 12 | print *, sum(randn(mean=0.0, std=1.0, ndim=3)**2) 13 | print *, sum(reshape(randn(mean=0.0, std=1.0, ndim=5*3), [5, 3])**2, dim=2) 14 | 15 | !> Possible output: 16 | 17 | !! -0.387298465 18 | !! -1.37615824 -0.529266298 5.43095016 19 | !! -1.35311902 1.81701779 0.772518456 -0.269844353 20 | 21 | !! 9.45483303 22 | !! 0.962645471 0.698421597 0.687875450 4.75956964 1.71025097 23 | 24 | end program demo_stats_randn -------------------------------------------------------------------------------- /example/stats/demo_stats_randu.f90: -------------------------------------------------------------------------------- 1 | program demo_stats_randu 2 | 3 | use forlab_stats, only: randu 4 | 5 | print *, "running `demo_stats_randu`.." 6 | 7 | print *, randu(start=1, end=2) 8 | print *, randu(start=1.0, end=2.0, ndim=3) 9 | print *, reshape(randu(1.0, 2.0, 2*2), [2,2]) 10 | 11 | !> Possible output: 12 | 13 | !! 2 14 | !! 1.65676987 1.11625218 1.03502560 15 | !! 1.74973476 1.82997108 1.77998054 1.14384007 16 | 17 | end program demo_stats_randu -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "forlab" 2 | version = "1.0.2" 3 | license = "MIT" 4 | author = "FORLAB contributors" 5 | maintainer = "@Fortran-Fans/FORALB" 6 | copyright = "2016-2021 FORLAB contributors" 7 | description = "A Fortran module that provides a lot of functions for scientific computing" 8 | categories = ["numerical"] 9 | keywords = ["numerical", "easy-to-use"] 10 | 11 | [build] 12 | auto-executables = false 13 | auto-examples = true 14 | auto-tests = false 15 | 16 | [dependencies] 17 | # Use stdlib as an upstream dependency. 18 | stdlib = { git = "https://github.com/fortran-lang/stdlib", branch = "stdlib-fpm" } 19 | 20 | [dev-dependencies] 21 | test-drive = { git = "https://github.com/fortran-lang/test-drive" } 22 | 23 | [library] 24 | source-dir="src" 25 | 26 | [install] 27 | library = true 28 | 29 | #=========================== tests ============================================= 30 | ## [io] tests 31 | [[test]] 32 | name = "io_bin" 33 | source-dir = "test/io" 34 | main = "test_io_bin.f90" 35 | [[test]] 36 | name = "io_disp" 37 | source-dir = "test/io" 38 | main = "test_io_disp.f90" 39 | [[test]] 40 | name = "io_file" 41 | source-dir = "test/io" 42 | main = "test_io_file.f90" 43 | [[test]] 44 | name = "io_color" 45 | source-dir = "test/io" 46 | main = "test_io_color.f90" 47 | [[test]] 48 | name = "io_read_line" 49 | source-dir = "test/io" 50 | main = "test_io_read_line.f90" 51 | 52 | ## [linalg] tests 53 | [[test]] 54 | name = "linalg_diff" 55 | source-dir = "test/linalg" 56 | main = "test_linalg_diff.f90" 57 | [[test]] 58 | name = "linalg_i" 59 | source-dir = "test/linalg" 60 | main = "test_linalg_i.f90" 61 | [[test]] 62 | name = "linalg_linspace" 63 | source-dir = "test/linalg" 64 | main = "test_linalg_linspace.f90" 65 | [[test]] 66 | name = "linalg_tri" 67 | source-dir = "test/linalg" 68 | main = "test_linalg_tri.f90" 69 | [[test]] 70 | name = "linalg_x" 71 | source-dir = "test/linalg" 72 | main = "test_linalg_x.f90" 73 | [[test]] 74 | name = "linalg_zerosones" 75 | source-dir = "test/linalg" 76 | main = "test_linalg_zerosones.f90" 77 | 78 | ## [math] tests 79 | [[test]] 80 | name = "math_angle" 81 | source-dir = "test/math" 82 | main = "test_math_angle.f90" 83 | [[test]] 84 | name = "math_degcir" 85 | source-dir = "test/math" 86 | main = "test_math_degcir.f90" 87 | [[test]] 88 | name = "math_is_close" 89 | source-dir = "test/math" 90 | main = "test_math_is_close.f90" 91 | [[test]] 92 | name = "math_all_close" 93 | source-dir = "test/math" 94 | main = "test_math_all_close.f90" 95 | [[test]] 96 | name = "math_arange" 97 | source-dir = "test/math" 98 | main = "test_math_arange.f90" 99 | [[test]] 100 | name = "math_signum" 101 | source-dir = "test/math" 102 | main = "test_math_signum.f90" 103 | 104 | ## [stats] tests 105 | [[test]] 106 | name = "stats" 107 | source-dir = "test/stats" 108 | main = "stats_checker.f90" 109 | [[test]] 110 | name = "stats_var" 111 | source-dir = "test/stats" 112 | main = "test_stats_var.f90" 113 | 114 | ## [sorting] tests 115 | [[test]] 116 | name = "sorting_sort" 117 | source-dir = "test/sorting" 118 | main = "test_sorting_sort.f90" 119 | 120 | ## [time] tests 121 | [[test]] 122 | name = "time_tioc" 123 | source-dir = "test/time" 124 | main = "test_time_tioc.f90" 125 | 126 | # New Unit-Test 127 | [[test]] 128 | name = "new" 129 | source-dir = "test" 130 | main = "checker.f90" -------------------------------------------------------------------------------- /meta-src/Makefile: -------------------------------------------------------------------------------- 1 | 2 | SRCFYPP := $(wildcard *.fypp) # Get all fypp files 3 | SRCFYPP := $(filter-out common.fypp, $(SRCFYPP)) # Filter some individual files 4 | 5 | # FPMSRCDIR: Output source files path 6 | FPMSRCDIR = ../src 7 | VPATH = $(FPMSRCDIR) 8 | 9 | SRCGEN := $(SRCFYPP:.fypp=.f90) 10 | 11 | .PHONY: all clean 12 | 13 | all: $(SRCGEN) 14 | 15 | clean: 16 | cd $(FPMSRCDIR); $(RM) $(SRCGEN) 17 | 18 | # GEN F90 files to `fpm/` from FYPP files 19 | $(SRCGEN): %.f90: %.fypp common.fypp 20 | @mkdir -p $(FPMSRCDIR) 21 | fypp $(FYPPFLAGS) $< $(FPMSRCDIR)/$@ 22 | fprettify -i 4 ../src/$@ 23 | -------------------------------------------------------------------------------- /meta-src/common.fypp: -------------------------------------------------------------------------------- 1 | #:mute 2 | 3 | #! Real kinds to be considered during templating 4 | #:set REAL_KINDS = ["sp", "dp"] 5 | 6 | #! Real types to be considere during templating 7 | #:set REAL_TYPES = ["real({})".format(k) for k in REAL_KINDS] 8 | 9 | #! Collected (kind, type) tuples for real types 10 | #:set REAL_KINDS_TYPES = list(zip(REAL_KINDS, REAL_TYPES)) 11 | 12 | #! Complex kinds to be considered during templating 13 | #:set CMPLX_KINDS = ["sp", "dp"] 14 | 15 | #! Complex types to be considere during templating 16 | #:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS] 17 | 18 | #! Collected (kind, type) tuples for complex types 19 | #:set CMPLX_KINDS_TYPES = list(zip(CMPLX_KINDS, CMPLX_TYPES)) 20 | 21 | #! Integer kinds to be considered during templating 22 | #:set INT_KINDS = ["int8", "int16", "int32", "int64"] 23 | 24 | #! Integer types to be considere during templating 25 | #:set INT_TYPES = ["integer({})".format(k) for k in INT_KINDS] 26 | 27 | #! Collected (kind, type) tuples for integer types 28 | #:set INT_KINDS_TYPES = list(zip(INT_KINDS, INT_TYPES)) 29 | 30 | #! Logical kinds to be considered during templating 31 | #:set LOG_KINDS = ["lk", "c_bool"] 32 | 33 | #! Logical types to be considered during templating 34 | #:set LOG_TYPES = ["logical({})".format(k) for k in LOG_KINDS] 35 | 36 | #! Collected (kind, type) tuples for logical types 37 | #:set LOG_KINDS_TYPES = list(zip(LOG_KINDS, LOG_TYPES)) 38 | 39 | #! Default Kinds 40 | #:set DK = "sp" 41 | 42 | #:set MAXRANK = 4 43 | 44 | #:def ranksuffix(RANK) 45 | $:'' if RANK == 0 else '(' + ':' + ',:' * (RANK - 1) + ')' 46 | #:enddef ranksuffix 47 | 48 | #:endmute 49 | -------------------------------------------------------------------------------- /meta-src/forlab_io_bin.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | 3 | submodule(forlab_io) forlab_io_bin 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES 10 | #:set RANKS = range(1, 4) 11 | #:for RANK in RANKS 12 | #:for k1,t1 in RCI_KINDS_TYPES 13 | module procedure loadbin_${RANK}$_${t1[0]}$${k1}$ 14 | type(file) :: infile 15 | character(*), parameter :: type = '${t1[0]}$${k1}$' 16 | integer, allocatable :: nsize(:) 17 | character(8) :: datatype 18 | integer :: data_dim 19 | #:if t1[0] == 'c' 20 | real(${k1}$), allocatable :: rp${ranksuffix(RANK)}$, ip${ranksuffix(RANK)}$ 21 | #:endif 22 | 23 | infile = file(filename, 'r b') 24 | if (infile%exist()) then 25 | call infile%open() 26 | read (infile%unit) datatype, data_dim 27 | if (trim(adjustl(datatype)) /= type) then 28 | call disp('Error: The program failed to try to read a '& 29 | //type//' array, but the file '//trim(filename)//& 30 | ' stored an array with a '//datatype//'.') 31 | stop 32 | endif 33 | if (data_dim /= ${RANK}$) then 34 | call disp('Error: The program failed to read the ' & 35 | //to_string(${RANK}$)//'-dimensional array. It may be that the file '& 36 | //trim(filename)//' stores an array of different dimensions '& 37 | //to_string(data_dim)//'.') 38 | stop 39 | endif 40 | 41 | allocate(nsize(${RANK}$)) 42 | read (infile%unit) nsize(:) 43 | 44 | #:if RANK == 1 45 | allocate (X(nsize(1))) 46 | #:elif RANK == 2 47 | allocate (X(nsize(1),nsize(2))) 48 | #:elif RANK == 3 49 | allocate (X(nsize(1),nsize(2),nsize(3))) 50 | #:endif 51 | 52 | #:if t1[0] == 'c' 53 | #:if RANK == 1 54 | allocate (rp(nsize(1))) 55 | allocate (ip(nsize(1))) 56 | #:elif RANK == 2 57 | allocate (rp(nsize(1),nsize(2))) 58 | allocate (ip(nsize(1),nsize(2))) 59 | #:elif RANK == 3 60 | allocate (rp(nsize(1),nsize(2),nsize(3))) 61 | allocate (ip(nsize(1),nsize(2),nsize(3))) 62 | #:endif 63 | read (infile%unit) rp, ip 64 | X = cmplx(rp,ip,${k1}$) 65 | #:else 66 | read (infile%unit) X 67 | #:endif 68 | 69 | call infile%close() 70 | else 71 | print *, "Error: '"//trim(filename)//"' not found" 72 | stop 73 | end if 74 | return 75 | end procedure loadbin_${RANK}$_${t1[0]}$${k1}$ 76 | #:endfor 77 | #:endfor 78 | 79 | #:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES 80 | #:set RANKS = range(1,4) 81 | #:for RANK in RANKS 82 | #:for k1,t1 in RCI_KINDS_TYPES 83 | module procedure savebin_${RANK}$_${t1[0]}$${k1}$ 84 | type(File) :: outfile 85 | character(8), parameter :: type = '${t1[0]}$${k1}$' 86 | 87 | outfile = file(filename, 'w b') 88 | call outfile%open() 89 | write(outfile%unit) type, int(${RANK}$, 4) 90 | #:if RANK == 1 91 | write(outfile%unit) size(X,1) 92 | #:elif RANK == 2 93 | write(outfile%unit) size(X,1), size(X,2) 94 | #:elif RANK == 3 95 | write(outfile%unit) size(X,1), size(X,2), size(X,3) 96 | #:endif 97 | 98 | #:if t1[0] == 'c' 99 | write (outfile%unit) real(X), imag(X) 100 | !! Precision 101 | #! Store complex array values. 102 | #:else 103 | write (outfile%unit) X 104 | #! Store real array values. 105 | #:endif 106 | 107 | call outfile%close() 108 | return 109 | end procedure savebin_${RANK}$_${t1[0]}$${k1}$ 110 | #:endfor 111 | #:endfor 112 | 113 | end submodule 114 | -------------------------------------------------------------------------------- /meta-src/forlab_io_progress_bar.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | 3 | submodule (forlab_io) forlab_io_progress_bar 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:for k1, t1 in INT_KINDS_TYPES 10 | module subroutine progress_bar_${k1}$(iter, itermax, step, symbol) 11 | 12 | ${t1}$, intent(in) :: iter, itermax 13 | ${t1}$, intent(in), optional :: step 14 | character(*), intent(in), optional :: symbol 15 | 16 | ${t1}$ :: step_, i, percentage 17 | character(:), allocatable :: symbol_, bar 18 | 19 | step_ = optval(step, 50_${k1}$) 20 | symbol_ = optval(symbol, "=") 21 | 22 | #! Initialize the bar 23 | bar = " [" 24 | do i = 1_${k1}$, step_ 25 | bar = bar//" " 26 | end do 27 | bar = bar//"]" 28 | 29 | #! Compute the percentage 30 | percentage = real(iter)/real(itermax)*100.0 31 | 32 | #! Fill the bar 33 | do i = 1_${k1}$, floor(percentage/(100.0/step_), ${k1}$) 34 | bar(3_${k1}$+i:3_${k1}$+i) = symbol_ 35 | end do 36 | 37 | #! Place the percentage 38 | i = ceiling((step_ + 2_${k1}$)/2.0, ${k1}$) 39 | write(bar(i+1_${k1}$:i+3_${k1}$), "(i3)") percentage 40 | bar(i+4_${k1}$:i+4_${k1}$) = "%" 41 | 42 | #! Fill the space 43 | if (percentage < 100_${k1}$ .and. percentage > 50_${k1}$ - 100_${k1}$/step_) & 44 | bar(i+1_${k1}$:i+1_${k1}$) = symbol_ 45 | 46 | #! Return to the beginning of the line and display the bar 47 | write(*, "(a1, A)", advance="no") achar(13), bar 48 | 49 | end subroutine progress_bar_${k1}$ 50 | #:endfor 51 | 52 | end submodule forlab_io_progress_bar -------------------------------------------------------------------------------- /meta-src/forlab_io_progress_perc.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | 3 | submodule (forlab_io) forlab_io_progress_perc 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:for k1, t1 in INT_KINDS_TYPES 10 | module subroutine progress_perc_${k1}$(iter, itermax, prefix) 11 | 12 | ${t1}$, intent(in) :: iter, itermax 13 | character(*), intent(in), optional :: prefix 14 | 15 | real(sp) :: percentage 16 | character(:), allocatable :: prefix_ 17 | 18 | prefix_ = optval(prefix, "") 19 | percentage = real(iter, sp)/real(itermax, sp)*100.0_sp 20 | write(*,"(a1,A,f6.2,A)",advance="no") achar(13), prefix_, percentage, "%" 21 | 22 | end subroutine progress_perc_${k1}$ 23 | #:endfor 24 | 25 | end submodule forlab_io_progress_perc -------------------------------------------------------------------------------- /meta-src/forlab_io_txt.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | 3 | submodule(forlab_io) forlab__io_txt 4 | 5 | use forlab_time, only: time_string 6 | implicit none 7 | 8 | contains 9 | 10 | #:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES 11 | #:set RANKS = range(1, 3) 12 | #:for RANK in RANKS 13 | #:for k1,t1 in RCI_KINDS_TYPES 14 | module procedure loadtxt_${RANK}$_${t1[0]}$${k1}$ 15 | integer :: i, data_dim 16 | type(File) :: infile 17 | character(*), parameter :: type = '${t1[0]}$${k1}$' 18 | character(8) :: datatype 19 | integer, allocatable :: nsize(:) 20 | 21 | allocate(nsize(${RANK}$)) 22 | infile = file(filename, 'r t') 23 | if (infile%exist()) then 24 | call infile%open() 25 | read(infile%unit,'(6X,A8,I8)') datatype, data_dim 26 | if (trim(adjustl(datatype)) /= type) then 27 | call error_stop('Error: The program failed to try to read a '& 28 | //type//' array, but the file '//trim(filename)//& 29 | 'stored an array with a '//datatype//'.') 30 | endif 31 | if (data_dim /= ${RANK}$) then 32 | call error_stop('Error: The program failed to read the ' & 33 | //to_string(${RANK}$)//'-dimensional array. It may be that the file '& 34 | //trim(filename)//' stores an array of different dimensions.') 35 | endif 36 | read(infile%unit, *) 37 | read(infile%unit, '(11X,${RANK}$I8)') nsize(:) 38 | read(infile%unit, *) 39 | 40 | #:if RANK == 1 41 | allocate (X(nsize(1))) 42 | #:elif RANK == 2 43 | allocate (X(nsize(1),nsize(2))) 44 | #:endif 45 | do i = 1, nsize(1) 46 | #:if RANK == 1 47 | read (infile%unit, *) X(i) 48 | #:elif RANK == 2 49 | read (infile%unit, *) X(i,:) 50 | #:endif 51 | end do 52 | call infile%close() 53 | else 54 | call error_stop("Error: '"//trim(filename)//"' not found") 55 | end if 56 | return 57 | end procedure loadtxt_${RANK}$_${t1[0]}$${k1}$ 58 | #:endfor 59 | #:endfor 60 | 61 | #:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES 62 | #:set RANKS = range(1,3) 63 | #:for RANK in RANKS 64 | #:for k1,t1 in RCI_KINDS_TYPES 65 | module procedure savetxt_${RANK}$_${t1[0]}$${k1}$ 66 | integer :: i, m 67 | type(file) :: outfile 68 | character(8), parameter :: type = '${t1[0]}$${k1}$' 69 | 70 | outfile = file(filename, 'w t') 71 | m = size(x, 1) 72 | 73 | call outfile%open() 74 | write(outfile%unit, '(A6,A8,I8)') 'TYPE: ', type, int(${RANK}$, 4) 75 | write(outfile%unit, '(A6,A)') 'DATA: ', time_string() 76 | 77 | #:if RANK == 1 78 | write(outfile%unit, '(A11,${RANK}$(I8))') 'DIMENSION: ', size(X,1) 79 | #:elif RANK == 2 80 | write(outfile%unit, '(A11,${RANK}$(I8))') 'DIMENSION: ', size(X,1), size(X,2) 81 | #:endif 82 | write(outfile%unit, '(A)') '---' 83 | 84 | do i = 1, m 85 | #:if RANK == 1 86 | write (outfile%unit, *) X(i) 87 | #:elif RANK == 2 88 | write (outfile%unit, *) X(i, :) 89 | #:endif 90 | end do 91 | call outfile%close() 92 | return 93 | end procedure savetxt_${RANK}$_${t1[0]}$${k1}$ 94 | #:endfor 95 | #:endfor 96 | end submodule forlab__io_txt 97 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_cat.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | #:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES 3 | 4 | submodule(forlab_linalg) forlab_linalg_cat 5 | 6 | implicit none 7 | 8 | contains 9 | 10 | #:set CATTYPE = ['horzcat', 'vertcat'] 11 | #:for c1 in CATTYPE 12 | #:for k1, t1 in RCI_KINDS_TYPES 13 | module procedure ${c1}$_${t1[0]}$_1_${k1}$ 14 | integer :: m1, m2 15 | 16 | m1 = size(x1) 17 | m2 = size(x2) 18 | #:if c1 == 'horzcat' 19 | result = zeros(max(m1, m2), 2) 20 | result(1:m1, 1) = x1 21 | result(1:m2, 2) = x2 22 | #:elif c1 == 'vertcat' 23 | result = zeros(m1 + m2, 1) 24 | result(1:m1, 1) = x1 25 | result(m1+1:m1+m2, 1) = x2 26 | #:endif 27 | 28 | end procedure ${c1}$_${t1[0]}$_1_${k1}$ 29 | 30 | module procedure ${c1}$_${t1[0]}$_2_${k1}$ 31 | integer :: m1, n1, m2, n2 32 | 33 | m1 = size(A1, 1) 34 | n1 = size(A1, 2) 35 | m2 = size(A2, 1) 36 | n2 = size(A2, 2) 37 | 38 | #:if c1 == 'horzcat' 39 | result = zeros(max(m1, m2), n1 + n2) 40 | result(1:m1, 1:n1) = A1 41 | result(1:m2, n1 + 1:) = A2 42 | #:elif c1 == 'vertcat' 43 | result = zeros(m1 + m2, max(n1, n2)) 44 | result(1:m1, 1:n1) = A1 45 | result(m1+1:m1+m2, 1:n2) = A2 46 | #:endif 47 | 48 | end procedure ${c1}$_${t1[0]}$_2_${k1}$ 49 | 50 | module procedure ${c1}$_${t1[0]}$_21_${k1}$ 51 | integer :: m1, n1, m2 52 | 53 | m1 = size(A1, 1) 54 | n1 = size(A1, 2) 55 | m2 = size(x2) 56 | #:if c1 == 'horzcat' 57 | result = zeros(max(m1, m2), n1 + 1) 58 | result(1:m1, 1:n1) = A1 59 | result(1:m2, n1 + 1) = x2 60 | #:elif c1 == 'vertcat' 61 | result = zeros(m1 + m2, n1) 62 | result(1:m1, 1:n1) = A1 63 | result(m1+1:m1+m2, 1) = x2 64 | #:endif 65 | return 66 | end procedure ${c1}$_${t1[0]}$_21_${k1}$ 67 | 68 | module procedure ${c1}$_${t1[0]}$_12_${k1}$ 69 | integer :: m1, m2, n2 70 | 71 | m1 = size(x1) 72 | m2 = size(A2, 1) 73 | n2 = size(A2, 2) 74 | #:if c1 == 'horzcat' 75 | result = zeros(max(m1, m2), n2 + 1) 76 | result(1:m1, 1) = x1 77 | result(1:m2, 2:) = A2 78 | #:elif c1 == 'vertcat' 79 | result = zeros(m1 + m2, n2) 80 | result(1:m1, 1) = x1 81 | result(m1+1:m1+m2, 1:n2) = A2 82 | #:endif 83 | 84 | end procedure ${c1}$_${t1[0]}$_12_${k1}$ 85 | #:endfor 86 | #:endfor 87 | 88 | end submodule forlab_linalg_cat 89 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_chol.fypp: -------------------------------------------------------------------------------- 1 | 2 | #:include "common.fypp" 3 | 4 | submodule(forlab_linalg) forlab_linalg_chol 5 | 6 | implicit none 7 | 8 | contains 9 | 10 | #:for k1,t1 in REAL_KINDS_TYPES 11 | module procedure chol_${k1}$ 12 | 13 | integer :: i, j, k, n 14 | ${t1}$ :: sum1, sum2 15 | ${t1}$, dimension(:), allocatable :: d 16 | ${t1}$, dimension(:,:), allocatable :: V 17 | ${t1}$, parameter::zero=0.0_${k1}$,one=1.0_${k1}$ 18 | call eig(A, V, d) 19 | deallocate(V) 20 | if (all(d >= zero)) then 21 | n = size(A, 1) 22 | L = zeros(n, n) 23 | L(1, 1) = sqrt(A(1, 1)) 24 | do i = 2, n 25 | L(i, 1) = A(i, 1)/L(1, 1) 26 | end do 27 | do i = 2, n 28 | do k = 1, i 29 | sum1 = zero 30 | sum2 = zero 31 | do j = 1, k - 1 32 | if (i == k) then 33 | sum1 = sum1 + (L(k, j)*L(k, j)) 34 | L(k, k) = sqrt(A(k, k) - sum1) 35 | elseif (i .gt. k) then 36 | sum2 = sum2 + (L(i, j)*L(k, j)) 37 | L(i, k) = (one/L(k, k))*(A(i, k) - sum2) 38 | else 39 | L(i, k) = zero 40 | end if 41 | end do 42 | end do 43 | end do 44 | else 45 | error stop "Error: in chol(A), A should be positive definite." 46 | end if 47 | deallocate(d) 48 | end procedure chol_${k1}$ 49 | #:endfor 50 | 51 | #:for k1,t1 in CMPLX_KINDS_TYPES 52 | #:endfor 53 | 54 | end submodule forlab_linalg_chol 55 | 56 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_det.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | 3 | submodule(forlab_linalg) forlab_linalg_det 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:for kind, type in REAL_KINDS_TYPES 10 | module procedure det_${kind}$ 11 | real(${kind}$), dimension(:, :), allocatable :: L, U 12 | integer :: m 13 | 14 | if (is_square(A)) then 15 | m = size(A, 1) 16 | if (m .eq. 2) then 17 | det = A(1, 1)*A(2, 2) - A(1, 2)*A(2, 1) 18 | elseif (m .eq. 3) then 19 | det = A(1, 1)*A(2, 2)*A(3, 3) & 20 | + A(2, 1)*A(3, 2)*A(1, 3) & 21 | + A(3, 1)*A(1, 2)*A(2, 3) & 22 | - A(1, 1)*A(3, 2)*A(2, 3) & 23 | - A(3, 1)*A(2, 2)*A(1, 3) & 24 | - A(2, 1)*A(1, 2)*A(3, 3) 25 | else 26 | call lu(A, L, U) 27 | det = product(diag(U)) 28 | if (present(outL)) outL = L 29 | if (present(outU)) outU = U 30 | end if 31 | else 32 | call error_stop("Error: in det(A), A should be square.") 33 | end if 34 | return 35 | 36 | end procedure det_${kind}$ 37 | #:endfor 38 | 39 | end submodule forlab_linalg_det 40 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_diag.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | submodule(forlab_linalg) forlab_linalg_diag 3 | 4 | implicit none 5 | 6 | contains 7 | #:for k1,t1 in REAL_KINDS_TYPES 8 | module procedure diag1_${k1}$ 9 | integer :: i, n 10 | n = min(size(A, 1), size(A, 2)) 11 | allocate (diag(n)) 12 | do i = 1, n 13 | diag(i) = A(i, i) 14 | end do 15 | return 16 | end procedure 17 | 18 | module procedure diag2_${k1}$ 19 | integer :: i, n 20 | n = size(x) 21 | diag = zeros(n, n) 22 | do i = 1, n 23 | diag(i, i) = x(i) 24 | end do 25 | return 26 | end procedure diag2_${k1}$ 27 | #:endfor 28 | 29 | end submodule forlab_linalg_diag 30 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_diff.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | #:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES 3 | submodule(forlab_linalg) forlab_linalg_diff 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:for k1, t1 in RI_KINDS_TYPES 10 | !> `diff` computes differences of arrays of the ${t1}$ type. 11 | pure module function diff_1_${k1}$(x, n) result(result) 12 | ${t1}$, dimension(:), intent(in) :: x 13 | integer, intent(in), optional :: n 14 | ${t1}$, dimension(:), allocatable :: result 15 | integer :: n_, i 16 | 17 | n_ = merge(n, 1, present(n)) 18 | 19 | result = x 20 | do i = 1, n_ 21 | result = result(2:) - result(:size(result) - 1) 22 | end do 23 | 24 | end function diff_1_${k1}$ 25 | 26 | !> `diff` computes differences of arrays of the ${t1}$ type. 27 | pure module function diff_2_${k1}$(A, n, dim) result(result) 28 | ${t1}$, dimension(:, :), intent(in) :: A 29 | integer, intent(in), optional :: n, dim 30 | ${t1}$, dimension(:, :), allocatable :: result 31 | integer :: n_, i 32 | 33 | n_ = merge(n, 1, present(n)) 34 | 35 | result = A 36 | if ((.not. present(dim)) .or. (dim == 1)) then 37 | do i = 1, n_ 38 | result = result(2:, :) - result(:size(result, 1) - 1, :) 39 | end do 40 | elseif (dim == 2) then 41 | do i = 1, n_ 42 | result = result(:, 2:) - result(:, :size(result, 2) - 1) 43 | end do 44 | end if 45 | 46 | end function diff_2_${k1}$ 47 | #:endfor 48 | 49 | end submodule forlab_linalg_diff 50 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_eig.fypp: -------------------------------------------------------------------------------- 1 | 2 | #:include 'common.fypp' 3 | 4 | submodule(forlab_linalg) forlab_linalg_eig 5 | 6 | implicit none 7 | 8 | contains 9 | 10 | #:for k1, t1 in REAL_KINDS_TYPES 11 | module procedure eig_${k1}$ 12 | integer :: opt_itermax, iter, i, j, k, n 13 | integer, dimension(:), allocatable :: idx 14 | ${t1}$ :: threshold, gapj, termi, termj, h, term, t, & 15 | theta, c, s, tau, g 16 | ${t1}$, dimension(:), allocatable :: bw, zw 17 | ${t1}$, dimension(:, :), allocatable :: B 18 | ${t1}$, parameter::zero=0.0_${k1}$,one=1.0_${k1}$,half=0.5_${k1}$ 19 | opt_itermax = 1000 20 | if (present(itermax)) opt_itermax = itermax 21 | 22 | if (.not. is_symmetric(A)) then 23 | stop "Error: in eig(A), A is not symmetric." 24 | else 25 | if (allocated(V)) deallocate (V) 26 | if (allocated(d)) deallocate (d) 27 | 28 | B = A 29 | n = size(B, 1) 30 | allocate(V(n, n)) 31 | call eye(V) 32 | d = diag(B) 33 | bw = d 34 | zw = zeros(n) 35 | 36 | iter = 0 37 | do while (iter .lt. opt_itermax) 38 | iter = iter + 1 39 | 40 | threshold = sqrt(sum(triu(B, 1)**2))/(4*n) 41 | if (threshold .eq. zero) exit 42 | 43 | do i = 1, n 44 | do j = i + 1, n 45 | gapj = 10.0_${k1}$*abs(B(i, j)) 46 | termi = gapj + abs(d(i)) 47 | termj = gapj + abs(d(j)) 48 | 49 | if ((iter .gt. 4) .and. (termi .eq. abs(d(i))) & 50 | .and. (termj .eq. abs(d(j)))) then 51 | B(i, j) = zero 52 | elseif (threshold .le. abs(B(i, j))) then 53 | h = d(j) - d(i) 54 | term = abs(h) + gapj 55 | 56 | if (term .eq. abs(h)) then 57 | t = B(i, j)/h 58 | else 59 | theta = half*h/B(i, j) 60 | t = one/(abs(theta) + sqrt(one + theta*theta)) 61 | if (theta .lt. zero) t = -t 62 | end if 63 | 64 | c = one/sqrt(one + t*t) 65 | s = t*c 66 | tau = s/(one + c) 67 | h = t*B(i, j) 68 | 69 | zw(i) = zw(i) - h 70 | zw(j) = zw(j) + h 71 | d(i) = d(i) - h 72 | d(j) = d(j) + h 73 | B(i, j) = zero 74 | 75 | do k = 1, i - 1 76 | g = B(k, i) 77 | h = B(k, j) 78 | B(k, i) = g - s*(h + g*tau) 79 | B(k, j) = h + s*(g - h*tau) 80 | end do 81 | 82 | do k = i + 1, j - 1 83 | g = B(i, k) 84 | h = B(k, j) 85 | B(i, k) = g - s*(h + g*tau) 86 | B(k, j) = h + s*(g - h*tau) 87 | end do 88 | 89 | do k = j + 1, n 90 | g = B(i, k) 91 | h = B(j, k) 92 | B(i, k) = g - s*(h + g*tau) 93 | B(j, k) = h + s*(g - h*tau) 94 | end do 95 | 96 | do k = 1, n 97 | g = V(k, i) 98 | h = V(k, j) 99 | v(k, i) = g - s*(h + g*tau) 100 | v(k, j) = h + s*(g - h*tau) 101 | end do 102 | 103 | end if 104 | end do 105 | end do 106 | 107 | bw = bw + zw 108 | d = bw 109 | zw = zero 110 | end do 111 | idx = argsort(d, 1) 112 | d = d(idx) 113 | V = V(:, idx) 114 | end if 115 | 116 | end procedure eig_${k1}$ 117 | #:endfor 118 | 119 | end submodule forlab_linalg_eig 120 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_eye.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | 3 | submodule(forlab_linalg) forlab_linalg_eye 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:for k1 in REAL_KINDS 10 | module procedure eye_${k1}$ 11 | integer :: i 12 | 13 | X = 0 14 | do i = 1, min(size(X,1), size(X,2)) 15 | X(i, i) = 1.0_${k1}$ 16 | end do 17 | return 18 | 19 | end procedure eye_${k1}$ 20 | #:endfor 21 | 22 | end submodule forlab_linalg_eye 23 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_linspace.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | 3 | submodule(forlab_linalg) forlab_linalg_linspace 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:for k1, t1 in REAL_KINDS_TYPES 10 | module procedure linspace_${k1}$ 11 | integer :: i, n 12 | real(${k1}$) :: by 13 | n = size(X) 14 | by = (to - from)/real(n - 1, ${k1}$) 15 | X = from + by*real([(i - 1, i=1, n)], ${k1}$) 16 | return 17 | end procedure linspace_${k1}$ 18 | 19 | module procedure logspace_${k1}$ 20 | call linspace(X, log10(from), log10(to)) 21 | X = 10._${k1}$**X 22 | return 23 | end procedure logspace_${k1}$ 24 | #:endfor 25 | 26 | end submodule forlab_linalg_linspace 27 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_lu.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | 3 | submodule(forlab_linalg) forlab_linalg_lu 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:for kind, type in REAL_KINDS_TYPES 10 | module procedure lu_${kind}$ 11 | integer :: i, j, k, m 12 | 13 | if (is_square(A)) then 14 | m = size(A, 1) 15 | if (.not. allocated(L)) then 16 | allocate(L(m,m)) 17 | call eye(L) 18 | endif 19 | if (.not. allocated(U)) then 20 | U = zeros(m, m) 21 | endif 22 | 23 | do i = 1, m 24 | do j = 1, m 25 | U(i, j) = A(i, j) 26 | do k = 1, i - 1 27 | U(i, j) = U(i, j) - L(i, k)*U(k, j) 28 | end do 29 | end do 30 | do j = i + 1, m 31 | L(j, i) = A(j, i) 32 | do k = 1, i - 1 33 | L(j, i) = L(j, i) - L(j, k)*U(k, i) 34 | end do 35 | L(j, i) = L(j, i)/U(i, i) 36 | end do 37 | end do 38 | else 39 | call error_stop("Error: in A = LU, A should be square.") 40 | end if 41 | return 42 | end procedure 43 | #:endfor 44 | 45 | end submodule forlab_linalg_lu 46 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_matpow.fypp: -------------------------------------------------------------------------------- 1 | 2 | 3 | #:include "common.fypp" 4 | 5 | submodule(forlab_linalg) forlab_linalg_matpow 6 | 7 | implicit none 8 | 9 | contains 10 | 11 | #:for k1,t1 in REAL_KINDS_TYPES 12 | module procedure matpow_${k1}$ 13 | ${t1}$,allocatable :: a1(:,:) 14 | ${t1}$,parameter::zero=0.0_${k1}$,one=1.0_${k1}$ 15 | integer::i,n,m 16 | if(.not. is_square(a))then 17 | call error_stop ("Error:A must be a square matrix") 18 | end if 19 | m=num 20 | if(m<0)then 21 | call error_stop ("Error: num must be a positive number") 22 | end if 23 | n=size(a,1) 24 | allocate(a1(n,n),source=a) 25 | allocate(c(n,n)) 26 | c=zero 27 | forall(i=1:n) 28 | c(i,i)=one 29 | end forall 30 | do 31 | if(mod(m,2)==1)then 32 | c=matmul(c,a1) 33 | end if 34 | m=shiftr(m, 1) 35 | if(m==0)exit 36 | a1=matmul(a1,a1) 37 | end do 38 | deallocate(a1) 39 | end procedure matpow_${k1}$ 40 | #:endfor 41 | 42 | end submodule forlab_linalg_matpow 43 | 44 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_norm.fypp: -------------------------------------------------------------------------------- 1 | 2 | 3 | #:include "common.fypp" 4 | 5 | submodule(forlab_linalg) forlab_linalg_norm 6 | 7 | implicit none 8 | 9 | contains 10 | 11 | #:for k1,t1 in REAL_KINDS_TYPES 12 | ${t1}$ module function norm1_${k1}$(x,p) 13 | ${t1}$, dimension(:), intent(in) :: x 14 | ${t1}$, intent(in), optional :: p 15 | ${t1}$::temp 16 | if (.not. present(p))then 17 | temp =2.0_${k1}$ 18 | else 19 | temp = p 20 | end if 21 | 22 | if(temp == 2.0_${k1}$) then 23 | norm1_${k1}$ = sqrt(sum(abs(x)**2)) 24 | elseif (temp == 1.0_${k1}$) then 25 | norm1_${k1}$ = sum(abs(x)) 26 | else 27 | norm1_${k1}$ = (sum(abs(x)**p))**(1.0_${k1}$/p) 28 | end if 29 | end function norm1_${k1}$ 30 | 31 | ${t1}$ module function norm2_${k1}$(A,p) 32 | ${t1}$, dimension(:,:), intent(in) :: A 33 | ${t1}$, intent(in), optional :: p 34 | ${t1}$::temp 35 | ${t1}$, dimension(:), allocatable :: w 36 | if (.not. present(p))then 37 | temp =2.0_${k1}$ 38 | else 39 | temp = p 40 | end if 41 | if(temp==2.0_${k1}$)then 42 | call svd(A, w) 43 | norm2_${k1}$ = maxval(w) 44 | elseif (temp == 1.0_${k1}$) then 45 | norm2_${k1}$ = maxval(sum(abs(A), dim=2)) 46 | end if 47 | end function norm2_${k1}$ 48 | #:endfor 49 | 50 | end submodule forlab_linalg_norm 51 | 52 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_outer.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | 3 | submodule(forlab_linalg) forlab_linalg_outer 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:for k1,t1 in INT_KINDS_TYPES 10 | module procedure outer_${k1}$ 11 | integer :: m, n 12 | 13 | m = size(x) 14 | n = size(y) 15 | allocate(outer_${k1}$, & 16 | source=spread(x, 2, n) * spread(y, 1, m)) 17 | 18 | end procedure outer_${k1}$ 19 | #:endfor 20 | 21 | #:for k1,t1 in REAL_KINDS_TYPES 22 | module procedure outer_${k1}$ 23 | integer :: m, n 24 | 25 | m = size(x) 26 | n = size(y) 27 | allocate(outer_${k1}$, & 28 | source=spread(x, 2, n) * spread(y, 1, m)) 29 | 30 | end procedure outer_${k1}$ 31 | #:endfor 32 | 33 | end submodule forlab_linalg_outer 34 | -------------------------------------------------------------------------------- /meta-src/forlab_linalg_qr.fypp: -------------------------------------------------------------------------------- 1 | 2 | #:include "common.fypp" 3 | 4 | submodule(forlab_linalg) forlab_linalg_qr 5 | 6 | implicit none 7 | 8 | contains 9 | 10 | #:for k1,t1 in REAL_KINDS_TYPES 11 | module procedure qr_${k1}$ 12 | ${t1}$,allocatable::v(:) 13 | integer::i,j,k,m,n,nn,templ 14 | ${t1}$::alpha,t,u 15 | ${t1}$,parameter::eps=epsilon(1.0_${k1}$),zero=0.0_${k1}$,one=1.0_${k1}$ 16 | m=size(a,1) 17 | n=size(a,2) 18 | if (mu) u=abs(r(i,k)) 41 | end do 42 | alpha=dot_product(r(k:m,k), r(k:m,k))/(u*u) 43 | if (r(k,k)>0) u=-u 44 | alpha=u*sqrt(alpha) 45 | if (abs(alpha)eps) then 50 | r(k,k)=(r(k,k)-alpha)/u 51 | r(k+1:m,k)=r(k+1:m,k)/u 52 | do j=1,m 53 | t=dot_product(r(k:m,k),q(k:m,j)) 54 | q(k:m,j)=q(k:m,j)-2*r(k:m,k)*t 55 | end do 56 | do j=k+1,n 57 | t=dot_product(r(k:m,k),r(k:m,j)) 58 | r(k:m,j)=r(k:m,j)-2*r(k:m,k)*t 59 | end do 60 | r(k,k)=alpha 61 | r(k+1:m,k)=zero 62 | end if 63 | end do 64 | do i=1,m-1 65 | do j=i+1,m 66 | t=q(i,j) 67 | q(i,j)=q(j,i) 68 | q(j,i)=t 69 | end do 70 | end do 71 | case(2) 72 | allocate(r(n,n)) 73 | r=zero 74 | q=a 75 | v=q(:,1) 76 | alpha=norm2(v) 77 | q(:,1)=v/alpha 78 | r(1,1)=alpha 79 | do i=2,n 80 | v=q(:,i) 81 | do j=1,i-1 82 | alpha=dot_product(q(:,i), q(:,j)) 83 | v=v-alpha*q(:,j) 84 | r(j,i)=alpha 85 | end do 86 | alpha=norm2(v) 87 | if(abs(alpha) Version: experimental 58 | !> 59 | !> `signum` returns the sign of variables. 60 | !> ([Specification](../page/specs/forlab_math.html#signum)) 61 | interface signum 62 | #:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES 63 | #:for k1, t1 in RCI_KINDS_TYPES 64 | ${t1}$ elemental module function signum_${t1[0]}$${k1}$(x) result(sign) 65 | ${t1}$, intent(in) :: x 66 | end function signum_${t1[0]}$${k1}$ 67 | #:endfor 68 | end interface signum 69 | 70 | interface cross 71 | #:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES 72 | #:for k1, t1 in RI_KINDS_TYPES 73 | pure module function cross_${t1[0]}$${k1}$(x, y) result(cross) 74 | ${t1}$, intent(in) :: x(3), y(3) 75 | ${t1}$ :: cross(3) 76 | end function cross_${t1[0]}$${k1}$ 77 | #:endfor 78 | end interface cross 79 | 80 | interface operator(.c.) 81 | #:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES 82 | #:for k1, t1 in RI_KINDS_TYPES 83 | procedure :: cross_${t1[0]}$${k1}$ 84 | #:endfor 85 | end interface operator(.c.) 86 | 87 | contains 88 | 89 | #! angle compute the phase angle. 90 | #:for kind, type in REAL_KINDS_TYPES 91 | elemental function angle_${kind}$(value) result(angle) 92 | real(${kind}$) :: angle 93 | complex(${kind}$),intent(in) :: value 94 | 95 | angle = aimag(log(value)) 96 | 97 | end function angle_${kind}$ 98 | #:endfor 99 | 100 | end module forlab_math -------------------------------------------------------------------------------- /meta-src/forlab_math_angle.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | 3 | submodule(forlab_math) forlab_math_angle 4 | implicit none 5 | contains 6 | 7 | #! Calculate the angle of two vectors. 8 | #:for k1, t1 in REAL_KINDS_TYPES 9 | pure module function angle_2_${k1}$(x, y) result(angle) 10 | ${t1}$, dimension(3), intent(in) :: x, y 11 | ${t1}$ :: angle 12 | 13 | angle = acos(dot_product(x, y)/(norm2(x)*norm2(y))) 14 | 15 | end function angle_2_${k1}$ 16 | #:endfor 17 | 18 | end submodule forlab_math_angle -------------------------------------------------------------------------------- /meta-src/forlab_math_cross.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | #:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES 3 | submodule(forlab_math) forlab_math_cross 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #! Cross product 10 | 11 | #:for k1, t1 in RI_KINDS_TYPES 12 | pure module function cross_${t1[0]}$${k1}$(x, y) result(cross) 13 | ${t1}$, intent(in) :: x(3), y(3) 14 | ${t1}$ :: cross(3) 15 | 16 | cross(1) = x(2)*y(3) - x(3)*y(2) 17 | cross(2) = x(3)*y(1) - x(1)*y(3) 18 | cross(3) = x(1)*y(2) - x(2)*y(1) 19 | 20 | end function cross_${t1[0]}$${k1}$ 21 | #:endfor 22 | 23 | end submodule forlab_math_cross -------------------------------------------------------------------------------- /meta-src/forlab_math_degcir.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | 3 | submodule(forlab_math) forlab_math_degcir 4 | 5 | implicit none 6 | #:for k1,t1 in REAL_KINDS_TYPES 7 | ${t1}$, parameter ::pi_${k1}$=acos(-1.0_${k1}$) 8 | #:endfor 9 | 10 | contains 11 | 12 | #:set CIR_NAME=["acos","asin","atan"] 13 | #:for l1 in CIR_NAME 14 | #:for k1,t1 in REAL_KINDS_TYPES 15 | module procedure ${l1}$d_${k1}$ 16 | ${l1}$d_${k1}$=${l1}$(x)*180/pi_${k1}$ 17 | end procedure 18 | 19 | #:endfor 20 | #:endfor 21 | #:set CIR_NAME=["cos","sin","tan"] 22 | #:for l1 in CIR_NAME 23 | #:for k1,t1 in REAL_KINDS_TYPES 24 | module procedure ${l1}$d_${k1}$ 25 | ${l1}$d_${k1}$=${l1}$(x*pi_${k1}$/180) 26 | end procedure 27 | 28 | #:endfor 29 | #:endfor 30 | end submodule forlab_math_degcir 31 | -------------------------------------------------------------------------------- /meta-src/forlab_math_signum.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | submodule(forlab_math) forlab_math_signum 3 | 4 | contains 5 | 6 | #! `signum` returns the sign of variables. 7 | #:for k1, t1 in REAL_KINDS_TYPES 8 | ${t1}$ elemental module function signum_${t1[0]}$${k1}$(x) result(sign) 9 | 10 | ${t1}$, intent(in) :: x 11 | 12 | if (x < 0.0_${k1}$) then; sign = -1.0_${k1}$ 13 | elseif (x > 0.0_${k1}$) then; sign = 1.0_${k1}$ 14 | else; sign = 0.0_${k1}$ 15 | end if 16 | 17 | end function signum_${t1[0]}$${k1}$ 18 | #:endfor 19 | 20 | #:for k1, t1 in INT_KINDS_TYPES 21 | ${t1}$ elemental module function signum_${t1[0]}$${k1}$(x) result(sign) 22 | 23 | ${t1}$, intent(in) :: x 24 | 25 | if (x < 0_${k1}$) then; sign = -1_${k1}$ 26 | elseif (x > 0_${k1}$) then; sign = 1_${k1}$ 27 | else; sign = 0_${k1}$ 28 | end if 29 | 30 | end function signum_${t1[0]}$${k1}$ 31 | #:endfor 32 | 33 | #:for k1, t1 in CMPLX_KINDS_TYPES 34 | ${t1}$ elemental module function signum_${t1[0]}$${k1}$(x) result(sign) 35 | 36 | ${t1}$, intent(in) :: x 37 | 38 | if (x == (0.0_${k1}$, 0.0_${k1}$)) then; sign = x 39 | else; sign = x/abs(x) 40 | end if 41 | 42 | end function signum_${t1[0]}$${k1}$ 43 | #:endfor 44 | 45 | end submodule forlab_math_signum -------------------------------------------------------------------------------- /meta-src/forlab_sorting.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | module forlab_sorting 3 | use stdlib_kinds, only: sp, dp, qp, & 4 | int8, int16, int32, int64 5 | use forlab_stats, only: randu 6 | implicit none 7 | private 8 | 9 | public :: argsort, sort 10 | 11 | interface argsort 12 | !! argsort generates the indices that would sort an array. 13 | #:for k1, t1 in INT_KINDS_TYPES+REAL_KINDS_TYPES 14 | module function argsort_${k1}$(x,order) 15 | integer,allocatable::argsort_${k1}$(:) 16 | ${t1}$,intent(in)::x(:) 17 | integer,optional,intent(in)::order 18 | end function argsort_${k1}$ 19 | #:endfor 20 | end interface argsort 21 | 22 | interface sort 23 | #:for k1, t1 in INT_KINDS_TYPES+REAL_KINDS_TYPES 24 | module function sort_${k1}$(x,order) 25 | ${t1}$,allocatable::sort_${k1}$(:) 26 | ${t1}$,intent(in)::x(:) 27 | integer,optional,intent(in)::order 28 | end function sort_${k1}$ 29 | #:endfor 30 | end interface sort 31 | 32 | end module forlab_sorting -------------------------------------------------------------------------------- /meta-src/forlab_sorting_argsort.fypp: -------------------------------------------------------------------------------- 1 | 2 | #:include 'common.fypp' 3 | 4 | submodule(forlab_sorting) forlab_sorting_argsort 5 | 6 | implicit none 7 | 8 | contains 9 | 10 | #:for k1, t1 in INT_KINDS_TYPES+REAL_KINDS_TYPES 11 | module procedure argsort_${k1}$ 12 | integer::i,n 13 | ${t1}$,allocatable::xsort(:) 14 | integer::order1 15 | n = size(x) 16 | xsort = x 17 | argsort_${k1}$ = [(i, i=1, n)] 18 | if (.not. present(order))then 19 | order1=1 20 | else 21 | order1=order 22 | end if 23 | call quickargsort_${k1}$(xsort, argsort_${k1}$, n, order1) 24 | end procedure argsort_${k1}$ 25 | recursive subroutine quickargsort_${k1}$(x, idx, n, order) 26 | ${t1}$, dimension(n), intent(inout) :: x 27 | integer, dimension(n), intent(inout) :: idx 28 | integer, intent(in) :: n, order 29 | integer:: left, right, marker 30 | ${t1}$ :: pivot,tmp1 31 | integer::tmp2 32 | if (n > 1) then 33 | left = 0 34 | right = n + 1 35 | pivot = x(randu(1, n)) 36 | select case (order) 37 | case (1) 38 | do while (left < right) 39 | left = left + 1 40 | right = right - 1 41 | do while (x(left) < pivot) 42 | left = left + 1 43 | end do 44 | do while (x(right) > pivot) 45 | right = right - 1 46 | end do 47 | if (left < right) then 48 | tmp1 = x(left) 49 | x(left) = x(right) 50 | x(right) = tmp1 51 | tmp2 = idx(left) 52 | idx(left) = idx(right) 53 | idx(right) = tmp2 54 | end if 55 | end do 56 | case (2) 57 | do while (left < right) 58 | left = left + 1 59 | right = right - 1 60 | do while (x(left) > pivot) 61 | left = left + 1 62 | end do 63 | do while (x(right) < pivot) 64 | right = right - 1 65 | end do 66 | if (left < right) then 67 | tmp1 = x(left) 68 | x(left) = x(right) 69 | x(right) = tmp1 70 | tmp2 = idx(left) 71 | idx(left) = idx(right) 72 | idx(right) = tmp2 73 | end if 74 | end do 75 | case default 76 | error stop "Error:Sort order MUST be 1 or 2" 77 | end select 78 | if (left == right) then 79 | marker = left + 1 80 | else 81 | marker = left 82 | end if 83 | call quickargsort_${k1}$(x(:marker - 1), idx(:marker - 1), marker - 1, order) 84 | call quickargsort_${k1}$(x(marker:), idx(marker:), n - marker + 1, order) 85 | end if 86 | end subroutine quickargsort_${k1}$ 87 | #:endfor 88 | 89 | end submodule forlab_sorting_argsort 90 | -------------------------------------------------------------------------------- /meta-src/forlab_sorting_sort.fypp: -------------------------------------------------------------------------------- 1 | 2 | #:include 'common.fypp' 3 | 4 | submodule(forlab_sorting) forlab_sorting_sort 5 | 6 | implicit none 7 | 8 | contains 9 | 10 | #:for k1, t1 in INT_KINDS_TYPES + REAL_KINDS_TYPES 11 | module procedure sort_${k1}$ 12 | integer :: n,order1 13 | n = size(x) 14 | sort_${k1}$ = x 15 | if (.not. present(order))then 16 | order1=1 17 | else 18 | order1=order 19 | end if 20 | call quicksort_${k1}$(sort_${k1}$, n, order1) 21 | end procedure sort_${k1}$ 22 | recursive subroutine quicksort_${k1}$(x, n, order) 23 | ${t1}$, dimension(n), intent(inout) :: x 24 | integer, intent(in) :: n, order 25 | integer :: left, right, marker 26 | ${t1}$ :: pivot, tmp 27 | 28 | if (n .gt. 1) then 29 | left = 0 30 | right = n + 1 31 | pivot = x(randu(1, n)) 32 | select case (order) 33 | case (1) 34 | do while (left .lt. right) 35 | left = left + 1 36 | right = right - 1 37 | do while (x(left) .lt. pivot) 38 | left = left + 1 39 | end do 40 | do while (x(right) .gt. pivot) 41 | right = right - 1 42 | end do 43 | if (left .lt. right) then 44 | tmp = x(left) 45 | x(left) = x(right) 46 | x(right) = tmp 47 | end if 48 | end do 49 | case (2) 50 | do while (left .lt. right) 51 | left = left + 1 52 | right = right - 1 53 | do while (x(left) .gt. pivot) 54 | left = left + 1 55 | end do 56 | do while (x(right) .lt. pivot) 57 | right = right - 1 58 | end do 59 | if (left .lt. right) then 60 | tmp = x(left) 61 | x(left) = x(right) 62 | x(right) = tmp 63 | end if 64 | end do 65 | case default 66 | error stop "Error:Sort order MUST be 1 or 2" 67 | end select 68 | if (left .eq. right) then 69 | marker = left + 1 70 | else 71 | marker = left 72 | end if 73 | call quicksort_${k1}$(x(:marker - 1), marker - 1, order) 74 | call quicksort_${k1}$(x(marker:), n - marker + 1, order) 75 | end if 76 | end subroutine quicksort_${k1}$ 77 | #:endfor 78 | 79 | end submodule forlab_sorting_sort 80 | 81 | -------------------------------------------------------------------------------- /meta-src/forlab_stats.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | 3 | module forlab_stats 4 | 5 | use stdlib_kinds, only: sp, dp, qp, int8, int16, int32, int64 6 | use stdlib_stats, only: mean 7 | implicit none 8 | private 9 | 10 | public :: mean, var, std 11 | public :: rng, randu, randn 12 | 13 | !> Version: Experimental 14 | !> 15 | !> Generate a normal distributed data scalar or vector. 16 | !> ([Specification](../page/specs/forlab_stats.html#randn)) 17 | interface randn 18 | #:for k1, t1 in REAL_KINDS_TYPES 19 | module function randn_0_${k1}$(mean, std) result(random) 20 | ${t1}$, intent(in) :: mean, std 21 | ${t1}$ :: random 22 | end function randn_0_${k1}$ 23 | module function randn_1_${k1}$(mean, std, ndim) result(random) 24 | ${t1}$, intent(in) :: mean, std 25 | integer, intent(in) :: ndim 26 | ${t1}$ :: random(ndim) 27 | end function randn_1_${k1}$ 28 | #:endfor 29 | end interface randn 30 | 31 | !> Version: Experimental 32 | !> 33 | !> Generate an uniformly distributed data scalar or vector. 34 | !> ([Specification](../page/specs/forlab_stats.html#randomrandu)) 35 | interface randu 36 | #:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES 37 | #:for k1, t1 in RI_KINDS_TYPES 38 | module function randu_0_${t1[0]}$${k1}$(start, end) result(random) 39 | ${t1}$, intent(in) :: start, end 40 | ${t1}$ :: random 41 | end function randu_0_${t1[0]}$${k1}$ 42 | module function randu_1_${t1[0]}$${k1}$(start, end, ndim) result(random) 43 | ${t1}$, intent(in) :: start, end 44 | integer, intent(in) :: ndim 45 | ${t1}$ :: random(ndim) 46 | end function randu_1_${t1[0]}$${k1}$ 47 | #:endfor 48 | end interface randu 49 | 50 | interface 51 | module subroutine rng(seed) 52 | integer, intent(in), optional :: seed 53 | end subroutine rng 54 | end interface 55 | 56 | #:set VSNAME = ['var', 'std'] 57 | #:for v1 in VSNAME 58 | interface ${v1}$ 59 | !! `std` computes vector and matrix standard deviations. 60 | !!([Specification](../module/forlab_var.html)) 61 | #:for k1, t1 in REAL_KINDS_TYPES 62 | ${t1}$ module function ${v1}$_1_${k1}$(x, w) 63 | ${t1}$, dimension(:), intent(in) :: x 64 | integer, intent(in), optional :: w 65 | end function ${v1}$_1_${k1}$ 66 | module function ${v1}$_2_${k1}$(A, w, dim) 67 | ${t1}$, dimension(:), allocatable :: ${v1}$_2_${k1}$ 68 | ${t1}$, dimension(:, :), intent(in) :: A 69 | integer, intent(in), optional :: w, dim 70 | end function ${v1}$_2_${k1}$ 71 | #:endfor 72 | end interface ${v1}$ 73 | #:endfor 74 | 75 | end module forlab_stats -------------------------------------------------------------------------------- /meta-src/forlab_stats_randn.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | submodule(forlab_stats) forlab_stats_randn 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | #! intrinsic 'random_number' is not PURE 9 | #:for k1, t1 in REAL_KINDS_TYPES 10 | module function randn_0_${k1}$(mean, std) result(random) 11 | ${t1}$, intent(in) :: mean, std 12 | ${t1}$ :: random 13 | 14 | real(${k1}$) :: u, v, s 15 | 16 | do 17 | call random_number(u) 18 | call random_number(v) 19 | u = 2._${k1}$*u - 1._${k1}$ 20 | v = 2._${k1}$*v - 1._${k1}$ 21 | s = u*u + v*v 22 | if ((s > 0._${k1}$) .and. (s < 1._${k1}$)) exit 23 | end do 24 | 25 | random = mean + u*sqrt(-2.0_${k1}$*log(s)/s)*std 26 | 27 | end function randn_0_${k1}$ 28 | 29 | module function randn_1_${k1}$(mean, std, ndim) result(random) 30 | ${t1}$, intent(in) :: mean, std 31 | integer, intent(in) :: ndim 32 | ${t1}$ :: random(ndim) 33 | 34 | integer :: i 35 | 36 | do i = 1, ndim 37 | random(i) = randn_0_${k1}$(mean, std) 38 | end do 39 | 40 | end function randn_1_${k1}$ 41 | #:endfor 42 | 43 | end submodule forlab_stats_randn 44 | -------------------------------------------------------------------------------- /meta-src/forlab_stats_randu.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | submodule(forlab_stats) forlab_stats_randu 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | #! intrinsic 'random_number' is not PURE 9 | #:for k1, t1 in REAL_KINDS_TYPES 10 | module function randu_0_${t1[0]}$${k1}$(start, end) result(random) 11 | ${t1}$, intent(in) :: start, end 12 | ${t1}$ :: random 13 | 14 | call random_number(random) 15 | random = start + random*(end - start) 16 | 17 | end function randu_0_${t1[0]}$${k1}$ 18 | 19 | module function randu_1_${t1[0]}$${k1}$(start, end, ndim) result(random) 20 | ${t1}$, intent(in) :: start, end 21 | integer, intent(in) :: ndim 22 | ${t1}$ :: random(ndim) 23 | 24 | call random_number(random) 25 | random = start + random*(end - start) 26 | 27 | end function randu_1_${t1[0]}$${k1}$ 28 | #:endfor 29 | 30 | #:for k1, t1 in INT_KINDS_TYPES 31 | module function randu_0_${t1[0]}$${k1}$(start, end) result(random) 32 | ${t1}$, intent(in) :: start, end 33 | ${t1}$ :: random 34 | 35 | real :: tmp 36 | 37 | call random_number(tmp) 38 | random = start + nint(tmp*real(end - start), ${k1}$) 39 | 40 | end function randu_0_${t1[0]}$${k1}$ 41 | 42 | module function randu_1_${t1[0]}$${k1}$(start, end, ndim) result(random) 43 | ${t1}$, intent(in) :: start, end 44 | integer, intent(in) :: ndim 45 | ${t1}$ :: random(ndim) 46 | 47 | real :: tmp(ndim) 48 | 49 | call random_number(tmp) 50 | random = start + nint(tmp*real(end - start), ${k1}$) 51 | 52 | end function randu_1_${t1[0]}$${k1}$ 53 | #:endfor 54 | 55 | end submodule forlab_stats_randu 56 | -------------------------------------------------------------------------------- /meta-src/forlab_stats_rng.fypp: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_stats) forlab_stats_rng 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure rng 9 | integer :: seed_size, values(8) 10 | integer, dimension(:), allocatable :: seed_put 11 | 12 | call random_seed(size=seed_size) 13 | allocate (seed_put(seed_size)) 14 | if (present(seed)) then 15 | seed_put = seed 16 | else 17 | call date_and_time(values=values) 18 | seed_put = values(8)*values(7)*values(6) 19 | end if 20 | call random_seed(put=seed_put) 21 | return 22 | end procedure rng 23 | 24 | end submodule forlab_stats_rng 25 | -------------------------------------------------------------------------------- /meta-src/forlab_stats_std.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | 3 | submodule(forlab_stats) forlab_stats_var 4 | 5 | implicit none 6 | 7 | contains 8 | 9 | #:set VSNAME = ['var', 'std'] 10 | #:for v1 in VSNAME 11 | #:for k1, t1 in REAL_KINDS_TYPES 12 | module procedure ${v1}$_1_${k1}$ 13 | integer :: opt_w 14 | 15 | opt_w = 0 16 | if (present(w)) opt_w = w 17 | #:if v1 == 'var' 18 | select case (opt_w) 19 | case (0) 20 | ${v1}$_1_${k1}$ = sum((x - mean(x))**2)/(size(x) - 1) 21 | case (1) 22 | ${v1}$_1_${k1}$ = sum((x - mean(x))**2)/size(x) 23 | end select 24 | #:elif v1 == 'std' 25 | ${v1}$_1_${k1}$ = sqrt(var_1_${k1}$(x, opt_w)) 26 | #:endif 27 | return 28 | end procedure ${v1}$_1_${k1}$ 29 | 30 | module procedure ${v1}$_2_${k1}$ 31 | #:if v1 == 'var' 32 | integer :: opt_w, i, m, n 33 | #:elif v1 == 'std' 34 | integer :: opt_w 35 | #:endif 36 | 37 | opt_w = 0 38 | if (present(w)) opt_w = w 39 | #:if v1 == 'var' 40 | m = size(A, 1) 41 | n = size(A, 2) 42 | if ((.not. present(dim)) .or. (dim == 1)) then 43 | allocate (${v1}$_2_${k1}$(n)) 44 | do i = 1, n 45 | ${v1}$_2_${k1}$(i) = ${v1}$_1_${k1}$(A(:, i), opt_w) 46 | end do 47 | elseif (dim == 2) then 48 | allocate (${v1}$_2_${k1}$(m)) 49 | do i = 1, m 50 | ${v1}$_2_${k1}$(i) = ${v1}$_1_${k1}$(A(i, :), opt_w) 51 | end do 52 | end if 53 | #:elif v1 == 'std' 54 | if (.not. present(dim)) then 55 | std_2_${k1}$ = sqrt(var_2_${k1}$(A, opt_w)) 56 | else 57 | std_2_${k1}$ = sqrt(var_2_${k1}$(A, opt_w, dim)) 58 | end if 59 | #:endif 60 | return 61 | end procedure ${v1}$_2_${k1}$ 62 | #:endfor 63 | #:endfor 64 | 65 | end submodule forlab_stats_var -------------------------------------------------------------------------------- /meta-src/forlab_time.fypp: -------------------------------------------------------------------------------- 1 | #:include "common.fypp" 2 | 3 | module forlab_time 4 | 5 | use forlab_io, only: disp 6 | use stdlib_kinds, only: sp, dp, qp, & 7 | int8, int16, int32, int64 8 | implicit none 9 | private 10 | 11 | public :: datenum, time_string 12 | public :: is_leap 13 | public :: tic, toc 14 | 15 | interface datenum 16 | real(dp) module function datenum0(year, month, day, hour, minute, & 17 | second, microsecond) 18 | integer, intent(in) :: year, month, day 19 | integer, intent(in), optional :: hour, minute, second, microsecond 20 | end function datenum0 21 | end interface datenum 22 | 23 | interface is_leap 24 | #:for k1 in INT_KINDS 25 | procedure :: is_leap_${k1}$ 26 | #:endfor 27 | end interface is_leap 28 | 29 | interface 30 | module subroutine tic() 31 | end subroutine tic 32 | end interface 33 | 34 | interface toc 35 | module subroutine toc_default() 36 | end subroutine toc_default 37 | #:for k1, t1 in REAL_KINDS_TYPES 38 | module subroutine toc_${k1}$(time) 39 | ${t1}$, intent(out) :: time 40 | end subroutine toc_${k1}$ 41 | #:endfor 42 | end interface toc 43 | 44 | contains 45 | 46 | #:for k1, t1 in INT_KINDS_TYPES 47 | logical function is_leap_${k1}$(year) result(is_leap) 48 | ${t1}$, intent(in) :: year 49 | if ((mod(year, 400) == 0) .or. & 50 | ((mod(year, 4) == 0) .and. (mod(year, 100) /= 0))) then 51 | is_leap = .true. 52 | else 53 | is_leap = .false. 54 | end if 55 | return 56 | end function is_leap_${k1}$ 57 | #:endfor 58 | 59 | character(19) function time_string() 60 | implicit none 61 | character(10) :: data, time 62 | call date_and_time(data, time) 63 | time_string = data(1:4)//'-'//data(5:6)//'-'//data(7:8)//' '//time(1:2) & 64 | //':'//time(3:4)//':'//time(5:6) 65 | #! 显示 日期时间时区 66 | end function time_string 67 | 68 | end module forlab_time -------------------------------------------------------------------------------- /meta-src/forlab_time_datenum.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | submodule(forlab_time) forlab_time_datenum 3 | 4 | use stdlib_strings, only: to_string 5 | implicit none 6 | 7 | contains 8 | 9 | module procedure datenum0 10 | integer :: i, days_per_month(12) 11 | 12 | if ((month .lt. 1) .and. (month .gt. 12)) then 13 | call disp("Error: month should be between 1 and 12 ("//to_string(month)//").") 14 | end if 15 | if ((day .lt. 1) .and. (day .gt. 31)) then 16 | call disp("Error: day should be between 1 and 31 ("//to_string(day)//").") 17 | end if 18 | if ((present(hour)) .and. (hour .lt. 0) .and. (hour .gt. 23)) then 19 | call disp("Error: hour should be between 0 and 23 ("//to_string(hour)//").") 20 | end if 21 | if ((present(minute)) .and. (minute .lt. 0) .and. (minute .gt. 59)) then 22 | call disp("Error: minute should be between 0 and 59 ("//to_string(minute)//").") 23 | end if 24 | if ((present(second)) .and. (second .lt. 0) .and. (second .gt. 59)) then 25 | call disp("Error: second should be between 0 and 59 ("//to_string(second)//").") 26 | end if 27 | if ((present(microsecond)) .and. (microsecond .lt. 0) .and. (microsecond .ge. 1.0d+6)) then 28 | call disp("Error: microsecond should be between 0 and 999,999 ("//to_string(microsecond)//").") 29 | end if 30 | days_per_month = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] 31 | datenum0 = 0 32 | do i = 0, year - 1 33 | if (is_leap(i)) then 34 | datenum0 = datenum0 + 366 35 | else 36 | datenum0 = datenum0 + 365 37 | end if 38 | end do 39 | datenum0 = datenum0 + sum(days_per_month(:month - 1)) 40 | if (is_leap(year) .and. (month .gt. 2)) datenum0 = datenum0 + 1 41 | datenum0 = datenum0 + day 42 | if (present(hour)) datenum0 = datenum0 + real(hour, kind=8)/24.0d0 43 | if (present(minute)) datenum0 = datenum0 + real(minute, kind=8)/(24.0d0*60.0d0) 44 | if (present(second)) datenum0 = datenum0 + real(second, kind=8)/(24.0d0*60.0d0*60.0d0) 45 | if (present(microsecond)) datenum0 = datenum0 + real(microsecond, kind=8)/(24.0d0*60.0d0*60.0d0*1.0d+6) 46 | return 47 | end procedure datenum0 48 | 49 | end submodule forlab_time_datenum 50 | -------------------------------------------------------------------------------- /meta-src/forlab_time_tioc.fypp: -------------------------------------------------------------------------------- 1 | #:include 'common.fypp' 2 | 3 | submodule(forlab_time) forlab_time_tioc 4 | 5 | use stdlib_strings, only: to_string 6 | implicit none 7 | real(dp), save :: tic_time 8 | 9 | contains 10 | module procedure tic 11 | integer :: values(8) 12 | call date_and_time(values=values) 13 | tic_time = datenum(values(1), values(2), values(3), values(5), & 14 | values(6), values(7), values(8)*1000) & 15 | *24.0d0*60.0d0*60.0d0 16 | return 17 | end procedure tic 18 | 19 | module procedure toc_default 20 | integer :: values(8) 21 | real(dp) :: toc_time, elapsed_time 22 | 23 | call date_and_time(values=values) 24 | toc_time = datenum(values(1), values(2), values(3), values(5), & 25 | values(6), values(7), values(8)*1000) & 26 | *24.0d0*60.0d0*60.0d0 27 | elapsed_time = toc_time - tic_time 28 | 29 | call disp("Elapsed time: " & 30 | //to_string(elapsed_time, "(F12.3)") & 31 | //" seconds") 32 | return 33 | end procedure toc_default 34 | 35 | #:for k1, t1 in REAL_KINDS_TYPES 36 | module procedure toc_${k1}$ 37 | integer :: values(8) 38 | real(dp) :: toc_time, elapsed_time 39 | 40 | call date_and_time(values=values) 41 | toc_time = datenum(values(1), values(2), values(3), values(5), & 42 | values(6), values(7), values(8)*1000) & 43 | *24.0d0*60.0d0*60.0d0 44 | elapsed_time = toc_time - tic_time 45 | 46 | time = elapsed_time !!\ATTENTION@zuo.zhihua@qq.com: Accuracy is converted here. 47 | return 48 | end procedure toc_${k1}$ 49 | #:endfor 50 | 51 | end submodule forlab_time_tioc 52 | -------------------------------------------------------------------------------- /src/forlab_color.f90: -------------------------------------------------------------------------------- 1 | module forlab_color 2 | 3 | ! Some parameters for our ANSI escape codes 4 | character(*), parameter :: esc = achar(27) ! Escape character. 5 | character(*), parameter :: default = esc//'[0m' ! Terminates an ANSI code. 6 | ! Foreground(font) Colours 7 | character(*), parameter :: red = esc//'[31m' 8 | character(*), parameter :: green = esc//'[32m' 9 | character(*), parameter :: yellow = esc//'[33m' 10 | character(*), parameter :: blue = esc//'[34m' 11 | character(*), parameter :: magenta = esc//'[35m' 12 | character(*), parameter :: cyan = esc//'[36m' 13 | character(*), parameter :: grey = esc//'[90m' !Bright-Black 14 | ! One background colour 15 | character(*), parameter :: background_green = esc//'[42m' 16 | ! Some other formatting 17 | character(*), parameter :: bold = esc//'[1m' 18 | character(*), parameter :: bold_blink = esc//'[1;5m' 19 | 20 | end module forlab_color 21 | -------------------------------------------------------------------------------- /src/forlab_io_color.f90: -------------------------------------------------------------------------------- 1 | !> Some prepared color to choosed. 2 | !> https://rosettacode.org/wiki/Terminal_control/Coloured_text#Fortran 3 | submodule(forlab_io) forlab_io_color 4 | 5 | contains 6 | 7 | module subroutine color(string) 8 | character(len=*), intent(in), optional :: string 9 | 10 | write (*, "(A)", advance="no") optval(string, achar(27)//'[0m') 11 | 12 | end subroutine color 13 | 14 | end submodule forlab_io_color 15 | -------------------------------------------------------------------------------- /src/forlab_io_progress_bar.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_io) forlab_io_progress_bar 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module subroutine progress_bar_int8(iter, itermax, step, symbol) 9 | 10 | integer(int8), intent(in) :: iter, itermax 11 | integer(int8), intent(in), optional :: step 12 | character(*), intent(in), optional :: symbol 13 | 14 | integer(int8) :: step_, i, percentage 15 | character(:), allocatable :: symbol_, bar 16 | 17 | step_ = optval(step, 50_int8) 18 | symbol_ = optval(symbol, "=") 19 | 20 | bar = " [" 21 | do i = 1_int8, step_ 22 | bar = bar//" " 23 | end do 24 | bar = bar//"]" 25 | 26 | percentage = real(iter)/real(itermax)*100.0 27 | 28 | do i = 1_int8, floor(percentage/(100.0/step_), int8) 29 | bar(3_int8 + i:3_int8 + i) = symbol_ 30 | end do 31 | 32 | i = ceiling((step_ + 2_int8)/2.0, int8) 33 | write (bar(i + 1_int8:i + 3_int8), "(i3)") percentage 34 | bar(i + 4_int8:i + 4_int8) = "%" 35 | 36 | if (percentage < 100_int8 .and. percentage > 50_int8 - 100_int8/step_) & 37 | bar(i + 1_int8:i + 1_int8) = symbol_ 38 | 39 | write (*, "(a1, A)", advance="no") achar(13), bar 40 | 41 | end subroutine progress_bar_int8 42 | module subroutine progress_bar_int16(iter, itermax, step, symbol) 43 | 44 | integer(int16), intent(in) :: iter, itermax 45 | integer(int16), intent(in), optional :: step 46 | character(*), intent(in), optional :: symbol 47 | 48 | integer(int16) :: step_, i, percentage 49 | character(:), allocatable :: symbol_, bar 50 | 51 | step_ = optval(step, 50_int16) 52 | symbol_ = optval(symbol, "=") 53 | 54 | bar = " [" 55 | do i = 1_int16, step_ 56 | bar = bar//" " 57 | end do 58 | bar = bar//"]" 59 | 60 | percentage = real(iter)/real(itermax)*100.0 61 | 62 | do i = 1_int16, floor(percentage/(100.0/step_), int16) 63 | bar(3_int16 + i:3_int16 + i) = symbol_ 64 | end do 65 | 66 | i = ceiling((step_ + 2_int16)/2.0, int16) 67 | write (bar(i + 1_int16:i + 3_int16), "(i3)") percentage 68 | bar(i + 4_int16:i + 4_int16) = "%" 69 | 70 | if (percentage < 100_int16 .and. percentage > 50_int16 - 100_int16/step_) & 71 | bar(i + 1_int16:i + 1_int16) = symbol_ 72 | 73 | write (*, "(a1, A)", advance="no") achar(13), bar 74 | 75 | end subroutine progress_bar_int16 76 | module subroutine progress_bar_int32(iter, itermax, step, symbol) 77 | 78 | integer(int32), intent(in) :: iter, itermax 79 | integer(int32), intent(in), optional :: step 80 | character(*), intent(in), optional :: symbol 81 | 82 | integer(int32) :: step_, i, percentage 83 | character(:), allocatable :: symbol_, bar 84 | 85 | step_ = optval(step, 50_int32) 86 | symbol_ = optval(symbol, "=") 87 | 88 | bar = " [" 89 | do i = 1_int32, step_ 90 | bar = bar//" " 91 | end do 92 | bar = bar//"]" 93 | 94 | percentage = real(iter)/real(itermax)*100.0 95 | 96 | do i = 1_int32, floor(percentage/(100.0/step_), int32) 97 | bar(3_int32 + i:3_int32 + i) = symbol_ 98 | end do 99 | 100 | i = ceiling((step_ + 2_int32)/2.0, int32) 101 | write (bar(i + 1_int32:i + 3_int32), "(i3)") percentage 102 | bar(i + 4_int32:i + 4_int32) = "%" 103 | 104 | if (percentage < 100_int32 .and. percentage > 50_int32 - 100_int32/step_) & 105 | bar(i + 1_int32:i + 1_int32) = symbol_ 106 | 107 | write (*, "(a1, A)", advance="no") achar(13), bar 108 | 109 | end subroutine progress_bar_int32 110 | module subroutine progress_bar_int64(iter, itermax, step, symbol) 111 | 112 | integer(int64), intent(in) :: iter, itermax 113 | integer(int64), intent(in), optional :: step 114 | character(*), intent(in), optional :: symbol 115 | 116 | integer(int64) :: step_, i, percentage 117 | character(:), allocatable :: symbol_, bar 118 | 119 | step_ = optval(step, 50_int64) 120 | symbol_ = optval(symbol, "=") 121 | 122 | bar = " [" 123 | do i = 1_int64, step_ 124 | bar = bar//" " 125 | end do 126 | bar = bar//"]" 127 | 128 | percentage = real(iter)/real(itermax)*100.0 129 | 130 | do i = 1_int64, floor(percentage/(100.0/step_), int64) 131 | bar(3_int64 + i:3_int64 + i) = symbol_ 132 | end do 133 | 134 | i = ceiling((step_ + 2_int64)/2.0, int64) 135 | write (bar(i + 1_int64:i + 3_int64), "(i3)") percentage 136 | bar(i + 4_int64:i + 4_int64) = "%" 137 | 138 | if (percentage < 100_int64 .and. percentage > 50_int64 - 100_int64/step_) & 139 | bar(i + 1_int64:i + 1_int64) = symbol_ 140 | 141 | write (*, "(a1, A)", advance="no") achar(13), bar 142 | 143 | end subroutine progress_bar_int64 144 | 145 | end submodule forlab_io_progress_bar 146 | -------------------------------------------------------------------------------- /src/forlab_io_progress_perc.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_io) forlab_io_progress_perc 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module subroutine progress_perc_int8(iter, itermax, prefix) 9 | 10 | integer(int8), intent(in) :: iter, itermax 11 | character(*), intent(in), optional :: prefix 12 | 13 | real(sp) :: percentage 14 | character(:), allocatable :: prefix_ 15 | 16 | prefix_ = optval(prefix, "") 17 | percentage = real(iter, sp)/real(itermax, sp)*100.0_sp 18 | write (*, "(a1,A,f6.2,A)", advance="no") achar(13), prefix_, percentage, "%" 19 | 20 | end subroutine progress_perc_int8 21 | module subroutine progress_perc_int16(iter, itermax, prefix) 22 | 23 | integer(int16), intent(in) :: iter, itermax 24 | character(*), intent(in), optional :: prefix 25 | 26 | real(sp) :: percentage 27 | character(:), allocatable :: prefix_ 28 | 29 | prefix_ = optval(prefix, "") 30 | percentage = real(iter, sp)/real(itermax, sp)*100.0_sp 31 | write (*, "(a1,A,f6.2,A)", advance="no") achar(13), prefix_, percentage, "%" 32 | 33 | end subroutine progress_perc_int16 34 | module subroutine progress_perc_int32(iter, itermax, prefix) 35 | 36 | integer(int32), intent(in) :: iter, itermax 37 | character(*), intent(in), optional :: prefix 38 | 39 | real(sp) :: percentage 40 | character(:), allocatable :: prefix_ 41 | 42 | prefix_ = optval(prefix, "") 43 | percentage = real(iter, sp)/real(itermax, sp)*100.0_sp 44 | write (*, "(a1,A,f6.2,A)", advance="no") achar(13), prefix_, percentage, "%" 45 | 46 | end subroutine progress_perc_int32 47 | module subroutine progress_perc_int64(iter, itermax, prefix) 48 | 49 | integer(int64), intent(in) :: iter, itermax 50 | character(*), intent(in), optional :: prefix 51 | 52 | real(sp) :: percentage 53 | character(:), allocatable :: prefix_ 54 | 55 | prefix_ = optval(prefix, "") 56 | percentage = real(iter, sp)/real(itermax, sp)*100.0_sp 57 | write (*, "(a1,A,f6.2,A)", advance="no") achar(13), prefix_, percentage, "%" 58 | 59 | end subroutine progress_perc_int64 60 | 61 | end submodule forlab_io_progress_perc 62 | -------------------------------------------------------------------------------- /src/forlab_io_read_line.f90: -------------------------------------------------------------------------------- 1 | submodule (forlab_io) forlab_io_read_line 2 | 3 | use, intrinsic :: iso_fortran_env, only: stdin => input_unit 4 | implicit none 5 | character(*), parameter :: nl = new_line("\n") 6 | integer, parameter :: buffer_len = 4096 7 | 8 | contains 9 | 10 | !> Read a line from the input unit. 11 | subroutine read_line(line, unit, iostat) 12 | 13 | character(:), allocatable, intent(out) :: line 14 | integer, intent(in), optional :: unit 15 | integer, intent(out), optional :: iostat 16 | 17 | integer :: unit_, iostat_ 18 | character(len=buffer_len) :: line_ 19 | character(len=buffer_len) :: msg 20 | 21 | unit_ = optval(unit, stdin) 22 | 23 | line = "" 24 | read(unit_, "(A)", iostat=iostat_, iomsg=msg) line_ 25 | if (present(iostat)) then 26 | iostat = iostat_ 27 | if (iostat_ == 0) line = trim(line_) 28 | else 29 | if (iostat_ == 0) then 30 | line = trim(line_) 31 | else 32 | error stop trim(msg) 33 | end if 34 | end if 35 | 36 | end subroutine read_line 37 | 38 | !> Read ASCII file as a string. 39 | subroutine read_file(string, file, iostat, keep_newline) 40 | 41 | character(:), allocatable, intent(out) :: string 42 | character(*), intent(in) :: file 43 | integer, intent(out), optional :: iostat 44 | logical, intent(in), optional :: keep_newline 45 | 46 | integer :: iostat_, unit, count, i 47 | character(:), allocatable :: string_ 48 | logical :: keep_newline_ 49 | 50 | keep_newline_ = optval(keep_newline, .true.) 51 | open(newunit=unit, file=file) 52 | 53 | string = "" 54 | count = countlines(file) 55 | do i = 1, count 56 | call read_line(string_, unit, iostat_) 57 | if (keep_newline_) string_ = string_ // nl 58 | string = string//string_ 59 | end do 60 | close(unit) 61 | 62 | end subroutine read_file 63 | 64 | end submodule forlab_io_read_line -------------------------------------------------------------------------------- /src/forlab_linalg_chol.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_chol 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure chol_sp 9 | 10 | integer :: i, j, k, n 11 | real(sp) :: sum1, sum2 12 | real(sp), dimension(:), allocatable :: d 13 | real(sp), dimension(:, :), allocatable :: V 14 | real(sp), parameter::zero = 0.0_sp, one = 1.0_sp 15 | call eig(A, V, d) 16 | deallocate (V) 17 | if (all(d >= zero)) then 18 | n = size(A, 1) 19 | L = zeros(n, n) 20 | L(1, 1) = sqrt(A(1, 1)) 21 | do i = 2, n 22 | L(i, 1) = A(i, 1)/L(1, 1) 23 | end do 24 | do i = 2, n 25 | do k = 1, i 26 | sum1 = zero 27 | sum2 = zero 28 | do j = 1, k - 1 29 | if (i == k) then 30 | sum1 = sum1 + (L(k, j)*L(k, j)) 31 | L(k, k) = sqrt(A(k, k) - sum1) 32 | elseif (i .gt. k) then 33 | sum2 = sum2 + (L(i, j)*L(k, j)) 34 | L(i, k) = (one/L(k, k))*(A(i, k) - sum2) 35 | else 36 | L(i, k) = zero 37 | end if 38 | end do 39 | end do 40 | end do 41 | else 42 | error stop "Error: in chol(A), A should be positive definite." 43 | end if 44 | deallocate (d) 45 | end procedure chol_sp 46 | module procedure chol_dp 47 | 48 | integer :: i, j, k, n 49 | real(dp) :: sum1, sum2 50 | real(dp), dimension(:), allocatable :: d 51 | real(dp), dimension(:, :), allocatable :: V 52 | real(dp), parameter::zero = 0.0_dp, one = 1.0_dp 53 | call eig(A, V, d) 54 | deallocate (V) 55 | if (all(d >= zero)) then 56 | n = size(A, 1) 57 | L = zeros(n, n) 58 | L(1, 1) = sqrt(A(1, 1)) 59 | do i = 2, n 60 | L(i, 1) = A(i, 1)/L(1, 1) 61 | end do 62 | do i = 2, n 63 | do k = 1, i 64 | sum1 = zero 65 | sum2 = zero 66 | do j = 1, k - 1 67 | if (i == k) then 68 | sum1 = sum1 + (L(k, j)*L(k, j)) 69 | L(k, k) = sqrt(A(k, k) - sum1) 70 | elseif (i .gt. k) then 71 | sum2 = sum2 + (L(i, j)*L(k, j)) 72 | L(i, k) = (one/L(k, k))*(A(i, k) - sum2) 73 | else 74 | L(i, k) = zero 75 | end if 76 | end do 77 | end do 78 | end do 79 | else 80 | error stop "Error: in chol(A), A should be positive definite." 81 | end if 82 | deallocate (d) 83 | end procedure chol_dp 84 | 85 | end submodule forlab_linalg_chol 86 | 87 | -------------------------------------------------------------------------------- /src/forlab_linalg_det.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_det 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure det_sp 9 | real(sp), dimension(:, :), allocatable :: L, U 10 | integer :: m 11 | 12 | if (is_square(A)) then 13 | m = size(A, 1) 14 | if (m .eq. 2) then 15 | det = A(1, 1)*A(2, 2) - A(1, 2)*A(2, 1) 16 | elseif (m .eq. 3) then 17 | det = A(1, 1)*A(2, 2)*A(3, 3) & 18 | + A(2, 1)*A(3, 2)*A(1, 3) & 19 | + A(3, 1)*A(1, 2)*A(2, 3) & 20 | - A(1, 1)*A(3, 2)*A(2, 3) & 21 | - A(3, 1)*A(2, 2)*A(1, 3) & 22 | - A(2, 1)*A(1, 2)*A(3, 3) 23 | else 24 | call lu(A, L, U) 25 | det = product(diag(U)) 26 | if (present(outL)) outL = L 27 | if (present(outU)) outU = U 28 | end if 29 | else 30 | call error_stop("Error: in det(A), A should be square.") 31 | end if 32 | return 33 | 34 | end procedure det_sp 35 | module procedure det_dp 36 | real(dp), dimension(:, :), allocatable :: L, U 37 | integer :: m 38 | 39 | if (is_square(A)) then 40 | m = size(A, 1) 41 | if (m .eq. 2) then 42 | det = A(1, 1)*A(2, 2) - A(1, 2)*A(2, 1) 43 | elseif (m .eq. 3) then 44 | det = A(1, 1)*A(2, 2)*A(3, 3) & 45 | + A(2, 1)*A(3, 2)*A(1, 3) & 46 | + A(3, 1)*A(1, 2)*A(2, 3) & 47 | - A(1, 1)*A(3, 2)*A(2, 3) & 48 | - A(3, 1)*A(2, 2)*A(1, 3) & 49 | - A(2, 1)*A(1, 2)*A(3, 3) 50 | else 51 | call lu(A, L, U) 52 | det = product(diag(U)) 53 | if (present(outL)) outL = L 54 | if (present(outU)) outU = U 55 | end if 56 | else 57 | call error_stop("Error: in det(A), A should be square.") 58 | end if 59 | return 60 | 61 | end procedure det_dp 62 | 63 | end submodule forlab_linalg_det 64 | -------------------------------------------------------------------------------- /src/forlab_linalg_diag.f90: -------------------------------------------------------------------------------- 1 | submodule(forlab_linalg) forlab_linalg_diag 2 | 3 | implicit none 4 | 5 | contains 6 | module procedure diag1_sp 7 | integer :: i, n 8 | n = min(size(A, 1), size(A, 2)) 9 | allocate (diag(n)) 10 | do i = 1, n 11 | diag(i) = A(i, i) 12 | end do 13 | return 14 | end procedure 15 | 16 | module procedure diag2_sp 17 | integer :: i, n 18 | n = size(x) 19 | diag = zeros(n, n) 20 | do i = 1, n 21 | diag(i, i) = x(i) 22 | end do 23 | return 24 | end procedure diag2_sp 25 | module procedure diag1_dp 26 | integer :: i, n 27 | n = min(size(A, 1), size(A, 2)) 28 | allocate (diag(n)) 29 | do i = 1, n 30 | diag(i) = A(i, i) 31 | end do 32 | return 33 | end procedure 34 | 35 | module procedure diag2_dp 36 | integer :: i, n 37 | n = size(x) 38 | diag = zeros(n, n) 39 | do i = 1, n 40 | diag(i, i) = x(i) 41 | end do 42 | return 43 | end procedure diag2_dp 44 | 45 | end submodule forlab_linalg_diag 46 | -------------------------------------------------------------------------------- /src/forlab_linalg_eye.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_eye 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure eye_sp 9 | integer :: i 10 | 11 | X = 0 12 | do i = 1, min(size(X, 1), size(X, 2)) 13 | X(i, i) = 1.0_sp 14 | end do 15 | return 16 | 17 | end procedure eye_sp 18 | module procedure eye_dp 19 | integer :: i 20 | 21 | X = 0 22 | do i = 1, min(size(X, 1), size(X, 2)) 23 | X(i, i) = 1.0_dp 24 | end do 25 | return 26 | 27 | end procedure eye_dp 28 | 29 | end submodule forlab_linalg_eye 30 | -------------------------------------------------------------------------------- /src/forlab_linalg_linspace.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_linspace 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure linspace_sp 9 | integer :: i, n 10 | real(sp) :: by 11 | n = size(X) 12 | by = (to - from)/real(n - 1, sp) 13 | X = from + by*real([(i - 1, i=1, n)], sp) 14 | return 15 | end procedure linspace_sp 16 | 17 | module procedure logspace_sp 18 | call linspace(X, log10(from), log10(to)) 19 | X = 10._sp**X 20 | return 21 | end procedure logspace_sp 22 | module procedure linspace_dp 23 | integer :: i, n 24 | real(dp) :: by 25 | n = size(X) 26 | by = (to - from)/real(n - 1, dp) 27 | X = from + by*real([(i - 1, i=1, n)], dp) 28 | return 29 | end procedure linspace_dp 30 | 31 | module procedure logspace_dp 32 | call linspace(X, log10(from), log10(to)) 33 | X = 10._dp**X 34 | return 35 | end procedure logspace_dp 36 | 37 | end submodule forlab_linalg_linspace 38 | -------------------------------------------------------------------------------- /src/forlab_linalg_lu.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_lu 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure lu_sp 9 | integer :: i, j, k, m 10 | 11 | if (is_square(A)) then 12 | m = size(A, 1) 13 | if (.not. allocated(L)) then 14 | allocate (L(m, m)) 15 | call eye(L) 16 | end if 17 | if (.not. allocated(U)) then 18 | U = zeros(m, m) 19 | end if 20 | 21 | do i = 1, m 22 | do j = 1, m 23 | U(i, j) = A(i, j) 24 | do k = 1, i - 1 25 | U(i, j) = U(i, j) - L(i, k)*U(k, j) 26 | end do 27 | end do 28 | do j = i + 1, m 29 | L(j, i) = A(j, i) 30 | do k = 1, i - 1 31 | L(j, i) = L(j, i) - L(j, k)*U(k, i) 32 | end do 33 | L(j, i) = L(j, i)/U(i, i) 34 | end do 35 | end do 36 | else 37 | call error_stop("Error: in A = LU, A should be square.") 38 | end if 39 | return 40 | end procedure 41 | module procedure lu_dp 42 | integer :: i, j, k, m 43 | 44 | if (is_square(A)) then 45 | m = size(A, 1) 46 | if (.not. allocated(L)) then 47 | allocate (L(m, m)) 48 | call eye(L) 49 | end if 50 | if (.not. allocated(U)) then 51 | U = zeros(m, m) 52 | end if 53 | 54 | do i = 1, m 55 | do j = 1, m 56 | U(i, j) = A(i, j) 57 | do k = 1, i - 1 58 | U(i, j) = U(i, j) - L(i, k)*U(k, j) 59 | end do 60 | end do 61 | do j = i + 1, m 62 | L(j, i) = A(j, i) 63 | do k = 1, i - 1 64 | L(j, i) = L(j, i) - L(j, k)*U(k, i) 65 | end do 66 | L(j, i) = L(j, i)/U(i, i) 67 | end do 68 | end do 69 | else 70 | call error_stop("Error: in A = LU, A should be square.") 71 | end if 72 | return 73 | end procedure 74 | 75 | end submodule forlab_linalg_lu 76 | -------------------------------------------------------------------------------- /src/forlab_linalg_matpow.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_matpow 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure matpow_sp 9 | real(sp), allocatable :: a1(:, :) 10 | real(sp), parameter::zero = 0.0_sp, one = 1.0_sp 11 | integer::i, n, m 12 | if (.not. is_square(a)) then 13 | call error_stop("Error:A must be a square matrix") 14 | end if 15 | m = num 16 | if (m < 0) then 17 | call error_stop("Error: num must be a positive number") 18 | end if 19 | n = size(a, 1) 20 | allocate (a1(n, n), source=a) 21 | allocate (c(n, n)) 22 | c = zero 23 | forall (i=1:n) 24 | c(i, i) = one 25 | end forall 26 | do 27 | if (mod(m, 2) == 1) then 28 | c = matmul(c, a1) 29 | end if 30 | m = shiftr(m, 1) 31 | if (m == 0) exit 32 | a1 = matmul(a1, a1) 33 | end do 34 | deallocate (a1) 35 | end procedure matpow_sp 36 | module procedure matpow_dp 37 | real(dp), allocatable :: a1(:, :) 38 | real(dp), parameter::zero = 0.0_dp, one = 1.0_dp 39 | integer::i, n, m 40 | if (.not. is_square(a)) then 41 | call error_stop("Error:A must be a square matrix") 42 | end if 43 | m = num 44 | if (m < 0) then 45 | call error_stop("Error: num must be a positive number") 46 | end if 47 | n = size(a, 1) 48 | allocate (a1(n, n), source=a) 49 | allocate (c(n, n)) 50 | c = zero 51 | forall (i=1:n) 52 | c(i, i) = one 53 | end forall 54 | do 55 | if (mod(m, 2) == 1) then 56 | c = matmul(c, a1) 57 | end if 58 | m = shiftr(m, 1) 59 | if (m == 0) exit 60 | a1 = matmul(a1, a1) 61 | end do 62 | deallocate (a1) 63 | end procedure matpow_dp 64 | 65 | end submodule forlab_linalg_matpow 66 | 67 | -------------------------------------------------------------------------------- /src/forlab_linalg_norm.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_norm 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | real(sp) module function norm1_sp(x, p) 9 | real(sp), dimension(:), intent(in) :: x 10 | real(sp), intent(in), optional :: p 11 | real(sp)::temp 12 | if (.not. present(p)) then 13 | temp = 2.0_sp 14 | else 15 | temp = p 16 | end if 17 | 18 | if (temp == 2.0_sp) then 19 | norm1_sp = sqrt(sum(abs(x)**2)) 20 | elseif (temp == 1.0_sp) then 21 | norm1_sp = sum(abs(x)) 22 | else 23 | norm1_sp = (sum(abs(x)**p))**(1.0_sp/p) 24 | end if 25 | end function norm1_sp 26 | 27 | real(sp) module function norm2_sp(A, p) 28 | real(sp), dimension(:, :), intent(in) :: A 29 | real(sp), intent(in), optional :: p 30 | real(sp)::temp 31 | real(sp), dimension(:), allocatable :: w 32 | if (.not. present(p)) then 33 | temp = 2.0_sp 34 | else 35 | temp = p 36 | end if 37 | if (temp == 2.0_sp) then 38 | call svd(A, w) 39 | norm2_sp = maxval(w) 40 | elseif (temp == 1.0_sp) then 41 | norm2_sp = maxval(sum(abs(A), dim=2)) 42 | end if 43 | end function norm2_sp 44 | real(dp) module function norm1_dp(x, p) 45 | real(dp), dimension(:), intent(in) :: x 46 | real(dp), intent(in), optional :: p 47 | real(dp)::temp 48 | if (.not. present(p)) then 49 | temp = 2.0_dp 50 | else 51 | temp = p 52 | end if 53 | 54 | if (temp == 2.0_dp) then 55 | norm1_dp = sqrt(sum(abs(x)**2)) 56 | elseif (temp == 1.0_dp) then 57 | norm1_dp = sum(abs(x)) 58 | else 59 | norm1_dp = (sum(abs(x)**p))**(1.0_dp/p) 60 | end if 61 | end function norm1_dp 62 | 63 | real(dp) module function norm2_dp(A, p) 64 | real(dp), dimension(:, :), intent(in) :: A 65 | real(dp), intent(in), optional :: p 66 | real(dp)::temp 67 | real(dp), dimension(:), allocatable :: w 68 | if (.not. present(p)) then 69 | temp = 2.0_dp 70 | else 71 | temp = p 72 | end if 73 | if (temp == 2.0_dp) then 74 | call svd(A, w) 75 | norm2_dp = maxval(w) 76 | elseif (temp == 1.0_dp) then 77 | norm2_dp = maxval(sum(abs(A), dim=2)) 78 | end if 79 | end function norm2_dp 80 | 81 | end submodule forlab_linalg_norm 82 | 83 | -------------------------------------------------------------------------------- /src/forlab_linalg_outer.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_outer 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure outer_int8 9 | integer :: m, n 10 | 11 | m = size(x) 12 | n = size(y) 13 | allocate (outer_int8, & 14 | source=spread(x, 2, n)*spread(y, 1, m)) 15 | 16 | end procedure outer_int8 17 | module procedure outer_int16 18 | integer :: m, n 19 | 20 | m = size(x) 21 | n = size(y) 22 | allocate (outer_int16, & 23 | source=spread(x, 2, n)*spread(y, 1, m)) 24 | 25 | end procedure outer_int16 26 | module procedure outer_int32 27 | integer :: m, n 28 | 29 | m = size(x) 30 | n = size(y) 31 | allocate (outer_int32, & 32 | source=spread(x, 2, n)*spread(y, 1, m)) 33 | 34 | end procedure outer_int32 35 | module procedure outer_int64 36 | integer :: m, n 37 | 38 | m = size(x) 39 | n = size(y) 40 | allocate (outer_int64, & 41 | source=spread(x, 2, n)*spread(y, 1, m)) 42 | 43 | end procedure outer_int64 44 | 45 | module procedure outer_sp 46 | integer :: m, n 47 | 48 | m = size(x) 49 | n = size(y) 50 | allocate (outer_sp, & 51 | source=spread(x, 2, n)*spread(y, 1, m)) 52 | 53 | end procedure outer_sp 54 | module procedure outer_dp 55 | integer :: m, n 56 | 57 | m = size(x) 58 | n = size(y) 59 | allocate (outer_dp, & 60 | source=spread(x, 2, n)*spread(y, 1, m)) 61 | 62 | end procedure outer_dp 63 | 64 | end submodule forlab_linalg_outer 65 | -------------------------------------------------------------------------------- /src/forlab_linalg_qr.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_qr 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure qr_sp 9 | real(sp), allocatable::v(:) 10 | integer::i, j, k, m, n, nn, templ 11 | real(sp)::alpha, t, u 12 | real(sp), parameter::eps = epsilon(1.0_sp), zero = 0.0_sp, one = 1.0_sp 13 | m = size(a, 1) 14 | n = size(a, 2) 15 | if (m < n) then 16 | call error_stop("Error:Matrix a dimension m < n ") 17 | end if 18 | if (present(l)) then 19 | templ = l 20 | else 21 | templ = 1 22 | end if 23 | select case (templ) 24 | case (1) 25 | r = a 26 | allocate (q(m, m)) 27 | q = zero 28 | r = a 29 | forall (i=1:m) 30 | q(i, i) = one 31 | end forall 32 | nn = n 33 | if (m == n) nn = m - 1 34 | do k = 1, nn 35 | u = zero 36 | do i = k, m 37 | if (abs(r(i, k)) > u) u = abs(r(i, k)) 38 | end do 39 | alpha = dot_product(r(k:m, k), r(k:m, k))/(u*u) 40 | if (r(k, k) > 0) u = -u 41 | alpha = u*sqrt(alpha) 42 | if (abs(alpha) < eps) then 43 | call error_stop("Error:matrix r linearly dependent") 44 | end if 45 | u = sqrt(2*alpha*(alpha - r(k, k))) 46 | if (abs(u) > eps) then 47 | r(k, k) = (r(k, k) - alpha)/u 48 | r(k + 1:m, k) = r(k + 1:m, k)/u 49 | do j = 1, m 50 | t = dot_product(r(k:m, k), q(k:m, j)) 51 | q(k:m, j) = q(k:m, j) - 2*r(k:m, k)*t 52 | end do 53 | do j = k + 1, n 54 | t = dot_product(r(k:m, k), r(k:m, j)) 55 | r(k:m, j) = r(k:m, j) - 2*r(k:m, k)*t 56 | end do 57 | r(k, k) = alpha 58 | r(k + 1:m, k) = zero 59 | end if 60 | end do 61 | do i = 1, m - 1 62 | do j = i + 1, m 63 | t = q(i, j) 64 | q(i, j) = q(j, i) 65 | q(j, i) = t 66 | end do 67 | end do 68 | case (2) 69 | allocate (r(n, n)) 70 | r = zero 71 | q = a 72 | v = q(:, 1) 73 | alpha = norm2(v) 74 | q(:, 1) = v/alpha 75 | r(1, 1) = alpha 76 | do i = 2, n 77 | v = q(:, i) 78 | do j = 1, i - 1 79 | alpha = dot_product(q(:, i), q(:, j)) 80 | v = v - alpha*q(:, j) 81 | r(j, i) = alpha 82 | end do 83 | alpha = norm2(v) 84 | if (abs(alpha) < eps) then 85 | call error_stop("Error:Matrix q linearly dependent") 86 | end if 87 | q(:, i) = v/alpha 88 | r(i, i) = alpha 89 | end do 90 | case default 91 | call Error_stop("Error: QR decomposition Type must be 1 or 2") 92 | end select 93 | end procedure qr_sp 94 | module procedure qr_dp 95 | real(dp), allocatable::v(:) 96 | integer::i, j, k, m, n, nn, templ 97 | real(dp)::alpha, t, u 98 | real(dp), parameter::eps = epsilon(1.0_dp), zero = 0.0_dp, one = 1.0_dp 99 | m = size(a, 1) 100 | n = size(a, 2) 101 | if (m < n) then 102 | call error_stop("Error:Matrix a dimension m < n ") 103 | end if 104 | if (present(l)) then 105 | templ = l 106 | else 107 | templ = 1 108 | end if 109 | select case (templ) 110 | case (1) 111 | r = a 112 | allocate (q(m, m)) 113 | q = zero 114 | r = a 115 | forall (i=1:m) 116 | q(i, i) = one 117 | end forall 118 | nn = n 119 | if (m == n) nn = m - 1 120 | do k = 1, nn 121 | u = zero 122 | do i = k, m 123 | if (abs(r(i, k)) > u) u = abs(r(i, k)) 124 | end do 125 | alpha = dot_product(r(k:m, k), r(k:m, k))/(u*u) 126 | if (r(k, k) > 0) u = -u 127 | alpha = u*sqrt(alpha) 128 | if (abs(alpha) < eps) then 129 | call error_stop("Error:matrix r linearly dependent") 130 | end if 131 | u = sqrt(2*alpha*(alpha - r(k, k))) 132 | if (abs(u) > eps) then 133 | r(k, k) = (r(k, k) - alpha)/u 134 | r(k + 1:m, k) = r(k + 1:m, k)/u 135 | do j = 1, m 136 | t = dot_product(r(k:m, k), q(k:m, j)) 137 | q(k:m, j) = q(k:m, j) - 2*r(k:m, k)*t 138 | end do 139 | do j = k + 1, n 140 | t = dot_product(r(k:m, k), r(k:m, j)) 141 | r(k:m, j) = r(k:m, j) - 2*r(k:m, k)*t 142 | end do 143 | r(k, k) = alpha 144 | r(k + 1:m, k) = zero 145 | end if 146 | end do 147 | do i = 1, m - 1 148 | do j = i + 1, m 149 | t = q(i, j) 150 | q(i, j) = q(j, i) 151 | q(j, i) = t 152 | end do 153 | end do 154 | case (2) 155 | allocate (r(n, n)) 156 | r = zero 157 | q = a 158 | v = q(:, 1) 159 | alpha = norm2(v) 160 | q(:, 1) = v/alpha 161 | r(1, 1) = alpha 162 | do i = 2, n 163 | v = q(:, i) 164 | do j = 1, i - 1 165 | alpha = dot_product(q(:, i), q(:, j)) 166 | v = v - alpha*q(:, j) 167 | r(j, i) = alpha 168 | end do 169 | alpha = norm2(v) 170 | if (abs(alpha) < eps) then 171 | call error_stop("Error:Matrix q linearly dependent") 172 | end if 173 | q(:, i) = v/alpha 174 | r(i, i) = alpha 175 | end do 176 | case default 177 | call Error_stop("Error: QR decomposition Type must be 1 or 2") 178 | end select 179 | end procedure qr_dp 180 | 181 | end submodule forlab_linalg_qr 182 | -------------------------------------------------------------------------------- /src/forlab_linalg_seq.f90: -------------------------------------------------------------------------------- 1 | submodule(forlab_linalg) forlab_linalg_seq 2 | 3 | implicit none 4 | 5 | contains 6 | 7 | module procedure seq_sp 8 | real(sp) :: by_ 9 | integer :: i, n 10 | 11 | by_ = optval(by, 1.0_sp) 12 | 13 | if (by <= 0) then 14 | call error_stop('Error: In seq, `by` should be greater than 0.') 15 | end if 16 | 17 | n = int(abs(to - from)/by_) + 1 18 | allocate (X(n)) 19 | if (from <= to) then 20 | X = from + by_*real([(i - 1, i=1, n)], sp) 21 | else 22 | X = from - by_*real([(i - 1, i=1, n)], sp) 23 | end if 24 | return 25 | end procedure seq_sp 26 | module procedure seq_dp 27 | real(dp) :: by_ 28 | integer :: i, n 29 | 30 | by_ = optval(by, 1.0_dp) 31 | 32 | if (by <= 0) then 33 | call error_stop('Error: In seq, `by` should be greater than 0.') 34 | end if 35 | 36 | n = int(abs(to - from)/by_) + 1 37 | allocate (X(n)) 38 | if (from <= to) then 39 | X = from + by_*real([(i - 1, i=1, n)], dp) 40 | else 41 | X = from - by_*real([(i - 1, i=1, n)], dp) 42 | end if 43 | return 44 | end procedure seq_dp 45 | module procedure seq_int8 46 | integer(int8) :: by_ 47 | integer :: i, n 48 | 49 | by_ = optval(by, 1_int8) 50 | 51 | if (by <= 0) then 52 | call error_stop('Error: In seq, `by` should be greater than 0.') 53 | end if 54 | 55 | n = (to - from)/by_ + 1 56 | allocate (X(n)) 57 | if (from <= to) then 58 | X = [(i, i=from, to, by_)] 59 | else 60 | X = [(i, i=from, to, -by_)] 61 | end if 62 | return 63 | end procedure seq_int8 64 | module procedure seq_int16 65 | integer(int16) :: by_ 66 | integer :: i, n 67 | 68 | by_ = optval(by, 1_int16) 69 | 70 | if (by <= 0) then 71 | call error_stop('Error: In seq, `by` should be greater than 0.') 72 | end if 73 | 74 | n = (to - from)/by_ + 1 75 | allocate (X(n)) 76 | if (from <= to) then 77 | X = [(i, i=from, to, by_)] 78 | else 79 | X = [(i, i=from, to, -by_)] 80 | end if 81 | return 82 | end procedure seq_int16 83 | module procedure seq_int32 84 | integer(int32) :: by_ 85 | integer :: i, n 86 | 87 | by_ = optval(by, 1_int32) 88 | 89 | if (by <= 0) then 90 | call error_stop('Error: In seq, `by` should be greater than 0.') 91 | end if 92 | 93 | n = (to - from)/by_ + 1 94 | allocate (X(n)) 95 | if (from <= to) then 96 | X = [(i, i=from, to, by_)] 97 | else 98 | X = [(i, i=from, to, -by_)] 99 | end if 100 | return 101 | end procedure seq_int32 102 | module procedure seq_int64 103 | integer(int64) :: by_ 104 | integer :: i, n 105 | 106 | by_ = optval(by, 1_int64) 107 | 108 | if (by <= 0) then 109 | call error_stop('Error: In seq, `by` should be greater than 0.') 110 | end if 111 | 112 | n = (to - from)/by_ + 1 113 | allocate (X(n)) 114 | if (from <= to) then 115 | X = [(i, i=from, to, by_)] 116 | else 117 | X = [(i, i=from, to, -by_)] 118 | end if 119 | return 120 | end procedure seq_int64 121 | 122 | end submodule forlab_linalg_seq 123 | -------------------------------------------------------------------------------- /src/forlab_linalg_solve.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_solve 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure solve_sp 9 | integer :: i, j, m, n 10 | real(sp), dimension(:), allocatable :: w, y 11 | real(sp), dimension(:, :), allocatable :: L, U, V 12 | m = size(A, 1) 13 | n = size(A, 2) 14 | if (is_square(A)) then 15 | x = zeros(m) 16 | y = zeros(m) 17 | y(1) = b(1) 18 | ! LU decomposition to solve LUx = b 19 | !=================================== 20 | call lu(A, L, U) 21 | ! Forward substitution: Ly = b 22 | !============================== 23 | do i = 2, m 24 | y(i) = b(i) 25 | do j = 1, i - 1 26 | y(i) = y(i) - y(j)*L(i, j) 27 | end do 28 | end do 29 | ! Back substitution: Ux = y 30 | !=========================== 31 | x(m) = y(m)/U(m, m) 32 | do i = m - 1, 1, -1 33 | x(i) = y(i) 34 | do j = m, i + 1, -1 35 | x(i) = x(i) - x(j)*U(i, j) 36 | end do 37 | x(i) = x(i)/U(i, i) 38 | end do 39 | else 40 | x = svdsolve(A, b) 41 | end if 42 | end procedure solve_sp 43 | module procedure solve_dp 44 | integer :: i, j, m, n 45 | real(dp), dimension(:), allocatable :: w, y 46 | real(dp), dimension(:, :), allocatable :: L, U, V 47 | m = size(A, 1) 48 | n = size(A, 2) 49 | if (is_square(A)) then 50 | x = zeros(m) 51 | y = zeros(m) 52 | y(1) = b(1) 53 | ! LU decomposition to solve LUx = b 54 | !=================================== 55 | call lu(A, L, U) 56 | ! Forward substitution: Ly = b 57 | !============================== 58 | do i = 2, m 59 | y(i) = b(i) 60 | do j = 1, i - 1 61 | y(i) = y(i) - y(j)*L(i, j) 62 | end do 63 | end do 64 | ! Back substitution: Ux = y 65 | !=========================== 66 | x(m) = y(m)/U(m, m) 67 | do i = m - 1, 1, -1 68 | x(i) = y(i) 69 | do j = m, i + 1, -1 70 | x(i) = x(i) - x(j)*U(i, j) 71 | end do 72 | x(i) = x(i)/U(i, i) 73 | end do 74 | else 75 | x = svdsolve(A, b) 76 | end if 77 | end procedure solve_dp 78 | 79 | end submodule forlab_linalg_solve 80 | 81 | -------------------------------------------------------------------------------- /src/forlab_linalg_svdsolve.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_svdsolve 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure svdsolve_sp 9 | integer :: i, k, n 10 | real(sp), dimension(:), allocatable :: w, xnorm, resnorm 11 | real(sp), dimension(:, :), allocatable :: U, V 12 | n = size(A, 2) 13 | k = n 14 | if (present(cutoff)) k = k - cutoff 15 | xnorm = zeros(n) 16 | resnorm = zeros(n) 17 | call svd(A, w, U, V) 18 | do i = 1, n 19 | x = matmul(matmul(matmul(V(:, :i), diag(1/w(:i))), transpose(U(:, :i))), b) 20 | xnorm(i) = norm(x) 21 | resnorm(i) = norm(matmul(A, x) - b) 22 | end do 23 | x = matmul(matmul(matmul(V(:, :k), diag(1/w(:k))), transpose(U(:, :k))), b) 24 | end procedure svdsolve_sp 25 | module procedure svdsolve_dp 26 | integer :: i, k, n 27 | real(dp), dimension(:), allocatable :: w, xnorm, resnorm 28 | real(dp), dimension(:, :), allocatable :: U, V 29 | n = size(A, 2) 30 | k = n 31 | if (present(cutoff)) k = k - cutoff 32 | xnorm = zeros(n) 33 | resnorm = zeros(n) 34 | call svd(A, w, U, V) 35 | do i = 1, n 36 | x = matmul(matmul(matmul(V(:, :i), diag(1/w(:i))), transpose(U(:, :i))), b) 37 | xnorm(i) = norm(x) 38 | resnorm(i) = norm(matmul(A, x) - b) 39 | end do 40 | x = matmul(matmul(matmul(V(:, :k), diag(1/w(:k))), transpose(U(:, :k))), b) 41 | end procedure svdsolve_dp 42 | 43 | end submodule forlab_linalg_svdsolve 44 | 45 | -------------------------------------------------------------------------------- /src/forlab_linalg_tri.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_linalg) forlab_linalg_tri 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure tril_int8 9 | integer::opt_k, i, m, n 10 | opt_k = 0 11 | if (present(k)) opt_k = k 12 | m = size(A, 1) 13 | n = size(A, 2) 14 | tril_int8 = A 15 | do i = 1, min(m, n) 16 | tril_int8(:i - opt_k - 1, i) = 0_int8 17 | end do 18 | end procedure tril_int8 19 | module procedure tril_int16 20 | integer::opt_k, i, m, n 21 | opt_k = 0 22 | if (present(k)) opt_k = k 23 | m = size(A, 1) 24 | n = size(A, 2) 25 | tril_int16 = A 26 | do i = 1, min(m, n) 27 | tril_int16(:i - opt_k - 1, i) = 0_int16 28 | end do 29 | end procedure tril_int16 30 | module procedure tril_int32 31 | integer::opt_k, i, m, n 32 | opt_k = 0 33 | if (present(k)) opt_k = k 34 | m = size(A, 1) 35 | n = size(A, 2) 36 | tril_int32 = A 37 | do i = 1, min(m, n) 38 | tril_int32(:i - opt_k - 1, i) = 0_int32 39 | end do 40 | end procedure tril_int32 41 | module procedure tril_int64 42 | integer::opt_k, i, m, n 43 | opt_k = 0 44 | if (present(k)) opt_k = k 45 | m = size(A, 1) 46 | n = size(A, 2) 47 | tril_int64 = A 48 | do i = 1, min(m, n) 49 | tril_int64(:i - opt_k - 1, i) = 0_int64 50 | end do 51 | end procedure tril_int64 52 | 53 | module procedure tril_sp 54 | integer::opt_k, i, m, n 55 | opt_k = 0 56 | if (present(k)) opt_k = k 57 | m = size(A, 1) 58 | n = size(A, 2) 59 | tril_sp = A 60 | do i = 1, min(m, n) 61 | tril_sp(:i - opt_k - 1, i) = 0.0_sp 62 | end do 63 | end procedure tril_sp 64 | module procedure tril_dp 65 | integer::opt_k, i, m, n 66 | opt_k = 0 67 | if (present(k)) opt_k = k 68 | m = size(A, 1) 69 | n = size(A, 2) 70 | tril_dp = A 71 | do i = 1, min(m, n) 72 | tril_dp(:i - opt_k - 1, i) = 0.0_dp 73 | end do 74 | end procedure tril_dp 75 | 76 | module procedure tril_csp 77 | integer::opt_k, i, m, n 78 | opt_k = 0 79 | if (present(k)) opt_k = k 80 | m = size(A, 1) 81 | n = size(A, 2) 82 | tril_csp = A 83 | do i = 1, min(m, n) 84 | tril_csp(:i - opt_k - 1, i) = cmplx(0.0_sp, 0.0_sp, kind=sp) 85 | end do 86 | end procedure tril_csp 87 | module procedure tril_cdp 88 | integer::opt_k, i, m, n 89 | opt_k = 0 90 | if (present(k)) opt_k = k 91 | m = size(A, 1) 92 | n = size(A, 2) 93 | tril_cdp = A 94 | do i = 1, min(m, n) 95 | tril_cdp(:i - opt_k - 1, i) = cmplx(0.0_dp, 0.0_dp, kind=dp) 96 | end do 97 | end procedure tril_cdp 98 | 99 | module procedure triu_int8 100 | integer::opt_k, i, m, n 101 | opt_k = 0 102 | if (present(k)) opt_k = k 103 | m = size(A, 1) 104 | n = size(A, 2) 105 | triu_int8 = A 106 | do i = 1, min(m, n) 107 | triu_int8(i - opt_k + 1:, i) = 0_int8 108 | end do 109 | end procedure triu_int8 110 | module procedure triu_int16 111 | integer::opt_k, i, m, n 112 | opt_k = 0 113 | if (present(k)) opt_k = k 114 | m = size(A, 1) 115 | n = size(A, 2) 116 | triu_int16 = A 117 | do i = 1, min(m, n) 118 | triu_int16(i - opt_k + 1:, i) = 0_int16 119 | end do 120 | end procedure triu_int16 121 | module procedure triu_int32 122 | integer::opt_k, i, m, n 123 | opt_k = 0 124 | if (present(k)) opt_k = k 125 | m = size(A, 1) 126 | n = size(A, 2) 127 | triu_int32 = A 128 | do i = 1, min(m, n) 129 | triu_int32(i - opt_k + 1:, i) = 0_int32 130 | end do 131 | end procedure triu_int32 132 | module procedure triu_int64 133 | integer::opt_k, i, m, n 134 | opt_k = 0 135 | if (present(k)) opt_k = k 136 | m = size(A, 1) 137 | n = size(A, 2) 138 | triu_int64 = A 139 | do i = 1, min(m, n) 140 | triu_int64(i - opt_k + 1:, i) = 0_int64 141 | end do 142 | end procedure triu_int64 143 | 144 | module procedure triu_sp 145 | integer::opt_k, i, m, n 146 | opt_k = 0 147 | if (present(k)) opt_k = k 148 | m = size(A, 1) 149 | n = size(A, 2) 150 | triu_sp = A 151 | do i = 1, min(m, n) 152 | triu_sp(i - opt_k + 1:, i) = 0.0_sp 153 | end do 154 | end procedure triu_sp 155 | module procedure triu_dp 156 | integer::opt_k, i, m, n 157 | opt_k = 0 158 | if (present(k)) opt_k = k 159 | m = size(A, 1) 160 | n = size(A, 2) 161 | triu_dp = A 162 | do i = 1, min(m, n) 163 | triu_dp(i - opt_k + 1:, i) = 0.0_dp 164 | end do 165 | end procedure triu_dp 166 | 167 | module procedure triu_csp 168 | integer::opt_k, i, m, n 169 | opt_k = 0 170 | if (present(k)) opt_k = k 171 | m = size(A, 1) 172 | n = size(A, 2) 173 | triu_csp = A 174 | do i = 1, min(m, n) 175 | triu_csp(i - opt_k + 1:, i) = cmplx(0.0_sp, 0.0_sp, kind=sp) 176 | end do 177 | end procedure triu_csp 178 | module procedure triu_cdp 179 | integer::opt_k, i, m, n 180 | opt_k = 0 181 | if (present(k)) opt_k = k 182 | m = size(A, 1) 183 | n = size(A, 2) 184 | triu_cdp = A 185 | do i = 1, min(m, n) 186 | triu_cdp(i - opt_k + 1:, i) = cmplx(0.0_dp, 0.0_dp, kind=dp) 187 | end do 188 | end procedure triu_cdp 189 | 190 | end submodule forlab_linalg_tri 191 | -------------------------------------------------------------------------------- /src/forlab_math_angle.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_math) forlab_math_angle 3 | implicit none 4 | contains 5 | 6 | pure module function angle_2_sp(x, y) result(angle) 7 | real(sp), dimension(3), intent(in) :: x, y 8 | real(sp) :: angle 9 | 10 | angle = acos(dot_product(x, y)/(norm2(x)*norm2(y))) 11 | 12 | end function angle_2_sp 13 | pure module function angle_2_dp(x, y) result(angle) 14 | real(dp), dimension(3), intent(in) :: x, y 15 | real(dp) :: angle 16 | 17 | angle = acos(dot_product(x, y)/(norm2(x)*norm2(y))) 18 | 19 | end function angle_2_dp 20 | 21 | end submodule forlab_math_angle 22 | -------------------------------------------------------------------------------- /src/forlab_math_arange.f90: -------------------------------------------------------------------------------- 1 | submodule(forlab_math) forlab_math_arange 2 | 3 | contains 4 | 5 | pure module function arange_r_sp(start, end, step) result(result) 6 | 7 | real(sp), intent(in) :: start 8 | real(sp), intent(in), optional :: end, step 9 | real(sp), allocatable :: result(:) 10 | 11 | real(sp) :: start_, end_, step_ 12 | integer :: i 13 | 14 | start_ = merge(start, 1.0_sp, present(end)) 15 | end_ = optval(end, start) 16 | step_ = optval(step, 1.0_sp) 17 | step_ = sign(merge(step_, 1.0_sp, step_ /= 0.0_sp), end_ - start_) 18 | 19 | allocate (result(floor((end_ - start_)/step_) + 1)) 20 | 21 | result = [(start_ + (i - 1)*step_, i=1, size(result), 1)] 22 | 23 | end function arange_r_sp 24 | pure module function arange_r_dp(start, end, step) result(result) 25 | 26 | real(dp), intent(in) :: start 27 | real(dp), intent(in), optional :: end, step 28 | real(dp), allocatable :: result(:) 29 | 30 | real(dp) :: start_, end_, step_ 31 | integer :: i 32 | 33 | start_ = merge(start, 1.0_dp, present(end)) 34 | end_ = optval(end, start) 35 | step_ = optval(step, 1.0_dp) 36 | step_ = sign(merge(step_, 1.0_dp, step_ /= 0.0_dp), end_ - start_) 37 | 38 | allocate (result(floor((end_ - start_)/step_) + 1)) 39 | 40 | result = [(start_ + (i - 1)*step_, i=1, size(result), 1)] 41 | 42 | end function arange_r_dp 43 | 44 | !> `arange` creates a vector of the `integer(int8)` type 45 | !> with evenly spaced values within a given interval. 46 | pure module function arange_i_int8(start, end, step) result(result) 47 | 48 | integer(int8), intent(in) :: start 49 | integer(int8), intent(in), optional :: end, step 50 | integer(int8), allocatable :: result(:) 51 | 52 | integer(int8) :: start_, end_, step_ 53 | integer(int8) :: i 54 | 55 | start_ = merge(start, 1_int8, present(end)) 56 | end_ = optval(end, start) 57 | step_ = optval(step, 1_int8) 58 | step_ = sign(merge(step_, 1_int8, step_ /= 0_int8), end_ - start_) 59 | 60 | allocate (result((end_ - start_)/step_ + 1_int8)) 61 | 62 | result = [(i, i=start_, end_, step_)] 63 | 64 | end function arange_i_int8 65 | !> `arange` creates a vector of the `integer(int16)` type 66 | !> with evenly spaced values within a given interval. 67 | pure module function arange_i_int16(start, end, step) result(result) 68 | 69 | integer(int16), intent(in) :: start 70 | integer(int16), intent(in), optional :: end, step 71 | integer(int16), allocatable :: result(:) 72 | 73 | integer(int16) :: start_, end_, step_ 74 | integer(int16) :: i 75 | 76 | start_ = merge(start, 1_int16, present(end)) 77 | end_ = optval(end, start) 78 | step_ = optval(step, 1_int16) 79 | step_ = sign(merge(step_, 1_int16, step_ /= 0_int16), end_ - start_) 80 | 81 | allocate (result((end_ - start_)/step_ + 1_int16)) 82 | 83 | result = [(i, i=start_, end_, step_)] 84 | 85 | end function arange_i_int16 86 | !> `arange` creates a vector of the `integer(int32)` type 87 | !> with evenly spaced values within a given interval. 88 | pure module function arange_i_int32(start, end, step) result(result) 89 | 90 | integer(int32), intent(in) :: start 91 | integer(int32), intent(in), optional :: end, step 92 | integer(int32), allocatable :: result(:) 93 | 94 | integer(int32) :: start_, end_, step_ 95 | integer(int32) :: i 96 | 97 | start_ = merge(start, 1_int32, present(end)) 98 | end_ = optval(end, start) 99 | step_ = optval(step, 1_int32) 100 | step_ = sign(merge(step_, 1_int32, step_ /= 0_int32), end_ - start_) 101 | 102 | allocate (result((end_ - start_)/step_ + 1_int32)) 103 | 104 | result = [(i, i=start_, end_, step_)] 105 | 106 | end function arange_i_int32 107 | !> `arange` creates a vector of the `integer(int64)` type 108 | !> with evenly spaced values within a given interval. 109 | pure module function arange_i_int64(start, end, step) result(result) 110 | 111 | integer(int64), intent(in) :: start 112 | integer(int64), intent(in), optional :: end, step 113 | integer(int64), allocatable :: result(:) 114 | 115 | integer(int64) :: start_, end_, step_ 116 | integer(int64) :: i 117 | 118 | start_ = merge(start, 1_int64, present(end)) 119 | end_ = optval(end, start) 120 | step_ = optval(step, 1_int64) 121 | step_ = sign(merge(step_, 1_int64, step_ /= 0_int64), end_ - start_) 122 | 123 | allocate (result((end_ - start_)/step_ + 1_int64)) 124 | 125 | result = [(i, i=start_, end_, step_)] 126 | 127 | end function arange_i_int64 128 | 129 | end submodule forlab_math_arange 130 | -------------------------------------------------------------------------------- /src/forlab_math_cross.f90: -------------------------------------------------------------------------------- 1 | submodule(forlab_math) forlab_math_cross 2 | 3 | implicit none 4 | 5 | contains 6 | 7 | pure module function cross_rsp(x, y) result(cross) 8 | real(sp), intent(in) :: x(3), y(3) 9 | real(sp) :: cross(3) 10 | 11 | cross(1) = x(2)*y(3) - x(3)*y(2) 12 | cross(2) = x(3)*y(1) - x(1)*y(3) 13 | cross(3) = x(1)*y(2) - x(2)*y(1) 14 | 15 | end function cross_rsp 16 | pure module function cross_rdp(x, y) result(cross) 17 | real(dp), intent(in) :: x(3), y(3) 18 | real(dp) :: cross(3) 19 | 20 | cross(1) = x(2)*y(3) - x(3)*y(2) 21 | cross(2) = x(3)*y(1) - x(1)*y(3) 22 | cross(3) = x(1)*y(2) - x(2)*y(1) 23 | 24 | end function cross_rdp 25 | pure module function cross_iint8(x, y) result(cross) 26 | integer(int8), intent(in) :: x(3), y(3) 27 | integer(int8) :: cross(3) 28 | 29 | cross(1) = x(2)*y(3) - x(3)*y(2) 30 | cross(2) = x(3)*y(1) - x(1)*y(3) 31 | cross(3) = x(1)*y(2) - x(2)*y(1) 32 | 33 | end function cross_iint8 34 | pure module function cross_iint16(x, y) result(cross) 35 | integer(int16), intent(in) :: x(3), y(3) 36 | integer(int16) :: cross(3) 37 | 38 | cross(1) = x(2)*y(3) - x(3)*y(2) 39 | cross(2) = x(3)*y(1) - x(1)*y(3) 40 | cross(3) = x(1)*y(2) - x(2)*y(1) 41 | 42 | end function cross_iint16 43 | pure module function cross_iint32(x, y) result(cross) 44 | integer(int32), intent(in) :: x(3), y(3) 45 | integer(int32) :: cross(3) 46 | 47 | cross(1) = x(2)*y(3) - x(3)*y(2) 48 | cross(2) = x(3)*y(1) - x(1)*y(3) 49 | cross(3) = x(1)*y(2) - x(2)*y(1) 50 | 51 | end function cross_iint32 52 | pure module function cross_iint64(x, y) result(cross) 53 | integer(int64), intent(in) :: x(3), y(3) 54 | integer(int64) :: cross(3) 55 | 56 | cross(1) = x(2)*y(3) - x(3)*y(2) 57 | cross(2) = x(3)*y(1) - x(1)*y(3) 58 | cross(3) = x(1)*y(2) - x(2)*y(1) 59 | 60 | end function cross_iint64 61 | 62 | end submodule forlab_math_cross 63 | -------------------------------------------------------------------------------- /src/forlab_math_degcir.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_math) forlab_math_degcir 3 | 4 | implicit none 5 | real(sp), parameter ::pi_sp = acos(-1.0_sp) 6 | real(dp), parameter ::pi_dp = acos(-1.0_dp) 7 | 8 | contains 9 | 10 | module procedure acosd_sp 11 | acosd_sp = acos(x)*180/pi_sp 12 | end procedure 13 | 14 | module procedure acosd_dp 15 | acosd_dp = acos(x)*180/pi_dp 16 | end procedure 17 | 18 | module procedure asind_sp 19 | asind_sp = asin(x)*180/pi_sp 20 | end procedure 21 | 22 | module procedure asind_dp 23 | asind_dp = asin(x)*180/pi_dp 24 | end procedure 25 | 26 | module procedure atand_sp 27 | atand_sp = atan(x)*180/pi_sp 28 | end procedure 29 | 30 | module procedure atand_dp 31 | atand_dp = atan(x)*180/pi_dp 32 | end procedure 33 | 34 | module procedure cosd_sp 35 | cosd_sp = cos(x*pi_sp/180) 36 | end procedure 37 | 38 | module procedure cosd_dp 39 | cosd_dp = cos(x*pi_dp/180) 40 | end procedure 41 | 42 | module procedure sind_sp 43 | sind_sp = sin(x*pi_sp/180) 44 | end procedure 45 | 46 | module procedure sind_dp 47 | sind_dp = sin(x*pi_dp/180) 48 | end procedure 49 | 50 | module procedure tand_sp 51 | tand_sp = tan(x*pi_sp/180) 52 | end procedure 53 | 54 | module procedure tand_dp 55 | tand_dp = tan(x*pi_dp/180) 56 | end procedure 57 | 58 | end submodule forlab_math_degcir 59 | -------------------------------------------------------------------------------- /src/forlab_math_is_close.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_math) forlab_math_is_close 3 | 4 | use, intrinsic :: ieee_arithmetic, only: ieee_is_nan 5 | implicit none 6 | 7 | contains 8 | 9 | elemental module logical function is_close_rsp(a, b, rel_tol, abs_tol, equal_nan) result(close) 10 | real(sp), intent(in) :: a, b 11 | real(sp), intent(in), optional :: rel_tol, abs_tol 12 | logical, intent(in), optional :: equal_nan 13 | logical :: equal_nan_ 14 | 15 | equal_nan_ = optval(equal_nan, .false.) 16 | 17 | if (ieee_is_nan(a) .or. ieee_is_nan(b)) then 18 | close = merge(.true., .false., equal_nan_ .and. ieee_is_nan(a) .and. ieee_is_nan(b)) 19 | else 20 | close = abs(a - b) <= max(abs(optval(rel_tol, 1.0e-9_sp)*max(abs(a), abs(b))), & 21 | abs(optval(abs_tol, 0.0_sp))) 22 | end if 23 | 24 | end function is_close_rsp 25 | elemental module logical function is_close_rdp(a, b, rel_tol, abs_tol, equal_nan) result(close) 26 | real(dp), intent(in) :: a, b 27 | real(dp), intent(in), optional :: rel_tol, abs_tol 28 | logical, intent(in), optional :: equal_nan 29 | logical :: equal_nan_ 30 | 31 | equal_nan_ = optval(equal_nan, .false.) 32 | 33 | if (ieee_is_nan(a) .or. ieee_is_nan(b)) then 34 | close = merge(.true., .false., equal_nan_ .and. ieee_is_nan(a) .and. ieee_is_nan(b)) 35 | else 36 | close = abs(a - b) <= max(abs(optval(rel_tol, 1.0e-9_dp)*max(abs(a), abs(b))), & 37 | abs(optval(abs_tol, 0.0_dp))) 38 | end if 39 | 40 | end function is_close_rdp 41 | 42 | elemental module logical function is_close_csp(a, b, rel_tol, abs_tol, equal_nan) result(close) 43 | complex(sp), intent(in) :: a, b 44 | real(sp), intent(in), optional :: rel_tol, abs_tol 45 | logical, intent(in), optional :: equal_nan 46 | 47 | close = is_close_rsp(a%re, b%re, rel_tol, abs_tol, equal_nan) .and. & 48 | is_close_rsp(a%im, b%im, rel_tol, abs_tol, equal_nan) 49 | 50 | end function is_close_csp 51 | elemental module logical function is_close_cdp(a, b, rel_tol, abs_tol, equal_nan) result(close) 52 | complex(dp), intent(in) :: a, b 53 | real(dp), intent(in), optional :: rel_tol, abs_tol 54 | logical, intent(in), optional :: equal_nan 55 | 56 | close = is_close_rdp(a%re, b%re, rel_tol, abs_tol, equal_nan) .and. & 57 | is_close_rdp(a%im, b%im, rel_tol, abs_tol, equal_nan) 58 | 59 | end function is_close_cdp 60 | 61 | end submodule forlab_math_is_close 62 | -------------------------------------------------------------------------------- /src/forlab_math_signum.f90: -------------------------------------------------------------------------------- 1 | submodule(forlab_math) forlab_math_signum 2 | 3 | contains 4 | 5 | real(sp) elemental module function signum_rsp(x) result(sign) 6 | 7 | real(sp), intent(in) :: x 8 | 9 | if (x < 0.0_sp) then; sign = -1.0_sp 10 | elseif (x > 0.0_sp) then; sign = 1.0_sp 11 | else; sign = 0.0_sp 12 | end if 13 | 14 | end function signum_rsp 15 | real(dp) elemental module function signum_rdp(x) result(sign) 16 | 17 | real(dp), intent(in) :: x 18 | 19 | if (x < 0.0_dp) then; sign = -1.0_dp 20 | elseif (x > 0.0_dp) then; sign = 1.0_dp 21 | else; sign = 0.0_dp 22 | end if 23 | 24 | end function signum_rdp 25 | 26 | integer(int8) elemental module function signum_iint8(x) result(sign) 27 | 28 | integer(int8), intent(in) :: x 29 | 30 | if (x < 0_int8) then; sign = -1_int8 31 | elseif (x > 0_int8) then; sign = 1_int8 32 | else; sign = 0_int8 33 | end if 34 | 35 | end function signum_iint8 36 | integer(int16) elemental module function signum_iint16(x) result(sign) 37 | 38 | integer(int16), intent(in) :: x 39 | 40 | if (x < 0_int16) then; sign = -1_int16 41 | elseif (x > 0_int16) then; sign = 1_int16 42 | else; sign = 0_int16 43 | end if 44 | 45 | end function signum_iint16 46 | integer(int32) elemental module function signum_iint32(x) result(sign) 47 | 48 | integer(int32), intent(in) :: x 49 | 50 | if (x < 0_int32) then; sign = -1_int32 51 | elseif (x > 0_int32) then; sign = 1_int32 52 | else; sign = 0_int32 53 | end if 54 | 55 | end function signum_iint32 56 | integer(int64) elemental module function signum_iint64(x) result(sign) 57 | 58 | integer(int64), intent(in) :: x 59 | 60 | if (x < 0_int64) then; sign = -1_int64 61 | elseif (x > 0_int64) then; sign = 1_int64 62 | else; sign = 0_int64 63 | end if 64 | 65 | end function signum_iint64 66 | 67 | complex(sp) elemental module function signum_csp(x) result(sign) 68 | 69 | complex(sp), intent(in) :: x 70 | 71 | if (x == (0.0_sp, 0.0_sp)) then; sign = x 72 | else; sign = x/abs(x) 73 | end if 74 | 75 | end function signum_csp 76 | complex(dp) elemental module function signum_cdp(x) result(sign) 77 | 78 | complex(dp), intent(in) :: x 79 | 80 | if (x == (0.0_dp, 0.0_dp)) then; sign = x 81 | else; sign = x/abs(x) 82 | end if 83 | 84 | end function signum_cdp 85 | 86 | end submodule forlab_math_signum 87 | -------------------------------------------------------------------------------- /src/forlab_sorting.f90: -------------------------------------------------------------------------------- 1 | module forlab_sorting 2 | use stdlib_kinds, only: sp, dp, qp, & 3 | int8, int16, int32, int64 4 | use forlab_stats, only: randu 5 | implicit none 6 | private 7 | 8 | public :: argsort, sort 9 | 10 | interface argsort 11 | !! argsort generates the indices that would sort an array. 12 | module function argsort_int8(x, order) 13 | integer, allocatable::argsort_int8(:) 14 | integer(int8), intent(in)::x(:) 15 | integer, optional, intent(in)::order 16 | end function argsort_int8 17 | module function argsort_int16(x, order) 18 | integer, allocatable::argsort_int16(:) 19 | integer(int16), intent(in)::x(:) 20 | integer, optional, intent(in)::order 21 | end function argsort_int16 22 | module function argsort_int32(x, order) 23 | integer, allocatable::argsort_int32(:) 24 | integer(int32), intent(in)::x(:) 25 | integer, optional, intent(in)::order 26 | end function argsort_int32 27 | module function argsort_int64(x, order) 28 | integer, allocatable::argsort_int64(:) 29 | integer(int64), intent(in)::x(:) 30 | integer, optional, intent(in)::order 31 | end function argsort_int64 32 | module function argsort_sp(x, order) 33 | integer, allocatable::argsort_sp(:) 34 | real(sp), intent(in)::x(:) 35 | integer, optional, intent(in)::order 36 | end function argsort_sp 37 | module function argsort_dp(x, order) 38 | integer, allocatable::argsort_dp(:) 39 | real(dp), intent(in)::x(:) 40 | integer, optional, intent(in)::order 41 | end function argsort_dp 42 | end interface argsort 43 | 44 | interface sort 45 | module function sort_int8(x, order) 46 | integer(int8), allocatable::sort_int8(:) 47 | integer(int8), intent(in)::x(:) 48 | integer, optional, intent(in)::order 49 | end function sort_int8 50 | module function sort_int16(x, order) 51 | integer(int16), allocatable::sort_int16(:) 52 | integer(int16), intent(in)::x(:) 53 | integer, optional, intent(in)::order 54 | end function sort_int16 55 | module function sort_int32(x, order) 56 | integer(int32), allocatable::sort_int32(:) 57 | integer(int32), intent(in)::x(:) 58 | integer, optional, intent(in)::order 59 | end function sort_int32 60 | module function sort_int64(x, order) 61 | integer(int64), allocatable::sort_int64(:) 62 | integer(int64), intent(in)::x(:) 63 | integer, optional, intent(in)::order 64 | end function sort_int64 65 | module function sort_sp(x, order) 66 | real(sp), allocatable::sort_sp(:) 67 | real(sp), intent(in)::x(:) 68 | integer, optional, intent(in)::order 69 | end function sort_sp 70 | module function sort_dp(x, order) 71 | real(dp), allocatable::sort_dp(:) 72 | real(dp), intent(in)::x(:) 73 | integer, optional, intent(in)::order 74 | end function sort_dp 75 | end interface sort 76 | 77 | end module forlab_sorting 78 | -------------------------------------------------------------------------------- /src/forlab_stats_randn.f90: -------------------------------------------------------------------------------- 1 | submodule(forlab_stats) forlab_stats_randn 2 | 3 | implicit none 4 | 5 | contains 6 | 7 | module function randn_0_sp(mean, std) result(random) 8 | real(sp), intent(in) :: mean, std 9 | real(sp) :: random 10 | 11 | real(sp) :: u, v, s 12 | 13 | do 14 | call random_number(u) 15 | call random_number(v) 16 | u = 2._sp*u - 1._sp 17 | v = 2._sp*v - 1._sp 18 | s = u*u + v*v 19 | if ((s > 0._sp) .and. (s < 1._sp)) exit 20 | end do 21 | 22 | random = mean + u*sqrt(-2.0_sp*log(s)/s)*std 23 | 24 | end function randn_0_sp 25 | 26 | module function randn_1_sp(mean, std, ndim) result(random) 27 | real(sp), intent(in) :: mean, std 28 | integer, intent(in) :: ndim 29 | real(sp) :: random(ndim) 30 | 31 | integer :: i 32 | 33 | do i = 1, ndim 34 | random(i) = randn_0_sp(mean, std) 35 | end do 36 | 37 | end function randn_1_sp 38 | module function randn_0_dp(mean, std) result(random) 39 | real(dp), intent(in) :: mean, std 40 | real(dp) :: random 41 | 42 | real(dp) :: u, v, s 43 | 44 | do 45 | call random_number(u) 46 | call random_number(v) 47 | u = 2._dp*u - 1._dp 48 | v = 2._dp*v - 1._dp 49 | s = u*u + v*v 50 | if ((s > 0._dp) .and. (s < 1._dp)) exit 51 | end do 52 | 53 | random = mean + u*sqrt(-2.0_dp*log(s)/s)*std 54 | 55 | end function randn_0_dp 56 | 57 | module function randn_1_dp(mean, std, ndim) result(random) 58 | real(dp), intent(in) :: mean, std 59 | integer, intent(in) :: ndim 60 | real(dp) :: random(ndim) 61 | 62 | integer :: i 63 | 64 | do i = 1, ndim 65 | random(i) = randn_0_dp(mean, std) 66 | end do 67 | 68 | end function randn_1_dp 69 | 70 | end submodule forlab_stats_randn 71 | -------------------------------------------------------------------------------- /src/forlab_stats_randu.f90: -------------------------------------------------------------------------------- 1 | submodule(forlab_stats) forlab_stats_randu 2 | 3 | implicit none 4 | 5 | contains 6 | 7 | module function randu_0_rsp(start, end) result(random) 8 | real(sp), intent(in) :: start, end 9 | real(sp) :: random 10 | 11 | call random_number(random) 12 | random = start + random*(end - start) 13 | 14 | end function randu_0_rsp 15 | 16 | module function randu_1_rsp(start, end, ndim) result(random) 17 | real(sp), intent(in) :: start, end 18 | integer, intent(in) :: ndim 19 | real(sp) :: random(ndim) 20 | 21 | call random_number(random) 22 | random = start + random*(end - start) 23 | 24 | end function randu_1_rsp 25 | module function randu_0_rdp(start, end) result(random) 26 | real(dp), intent(in) :: start, end 27 | real(dp) :: random 28 | 29 | call random_number(random) 30 | random = start + random*(end - start) 31 | 32 | end function randu_0_rdp 33 | 34 | module function randu_1_rdp(start, end, ndim) result(random) 35 | real(dp), intent(in) :: start, end 36 | integer, intent(in) :: ndim 37 | real(dp) :: random(ndim) 38 | 39 | call random_number(random) 40 | random = start + random*(end - start) 41 | 42 | end function randu_1_rdp 43 | 44 | module function randu_0_iint8(start, end) result(random) 45 | integer(int8), intent(in) :: start, end 46 | integer(int8) :: random 47 | 48 | real :: tmp 49 | 50 | call random_number(tmp) 51 | random = start + nint(tmp*real(end - start), int8) 52 | 53 | end function randu_0_iint8 54 | 55 | module function randu_1_iint8(start, end, ndim) result(random) 56 | integer(int8), intent(in) :: start, end 57 | integer, intent(in) :: ndim 58 | integer(int8) :: random(ndim) 59 | 60 | real :: tmp(ndim) 61 | 62 | call random_number(tmp) 63 | random = start + nint(tmp*real(end - start), int8) 64 | 65 | end function randu_1_iint8 66 | module function randu_0_iint16(start, end) result(random) 67 | integer(int16), intent(in) :: start, end 68 | integer(int16) :: random 69 | 70 | real :: tmp 71 | 72 | call random_number(tmp) 73 | random = start + nint(tmp*real(end - start), int16) 74 | 75 | end function randu_0_iint16 76 | 77 | module function randu_1_iint16(start, end, ndim) result(random) 78 | integer(int16), intent(in) :: start, end 79 | integer, intent(in) :: ndim 80 | integer(int16) :: random(ndim) 81 | 82 | real :: tmp(ndim) 83 | 84 | call random_number(tmp) 85 | random = start + nint(tmp*real(end - start), int16) 86 | 87 | end function randu_1_iint16 88 | module function randu_0_iint32(start, end) result(random) 89 | integer(int32), intent(in) :: start, end 90 | integer(int32) :: random 91 | 92 | real :: tmp 93 | 94 | call random_number(tmp) 95 | random = start + nint(tmp*real(end - start), int32) 96 | 97 | end function randu_0_iint32 98 | 99 | module function randu_1_iint32(start, end, ndim) result(random) 100 | integer(int32), intent(in) :: start, end 101 | integer, intent(in) :: ndim 102 | integer(int32) :: random(ndim) 103 | 104 | real :: tmp(ndim) 105 | 106 | call random_number(tmp) 107 | random = start + nint(tmp*real(end - start), int32) 108 | 109 | end function randu_1_iint32 110 | module function randu_0_iint64(start, end) result(random) 111 | integer(int64), intent(in) :: start, end 112 | integer(int64) :: random 113 | 114 | real :: tmp 115 | 116 | call random_number(tmp) 117 | random = start + nint(tmp*real(end - start), int64) 118 | 119 | end function randu_0_iint64 120 | 121 | module function randu_1_iint64(start, end, ndim) result(random) 122 | integer(int64), intent(in) :: start, end 123 | integer, intent(in) :: ndim 124 | integer(int64) :: random(ndim) 125 | 126 | real :: tmp(ndim) 127 | 128 | call random_number(tmp) 129 | random = start + nint(tmp*real(end - start), int64) 130 | 131 | end function randu_1_iint64 132 | 133 | end submodule forlab_stats_randu 134 | -------------------------------------------------------------------------------- /src/forlab_stats_rng.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_stats) forlab_stats_rng 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure rng 9 | integer :: seed_size, values(8) 10 | integer, dimension(:), allocatable :: seed_put 11 | 12 | call random_seed(size=seed_size) 13 | allocate (seed_put(seed_size)) 14 | if (present(seed)) then 15 | seed_put = seed 16 | else 17 | call date_and_time(values=values) 18 | seed_put = values(8)*values(7)*values(6) 19 | end if 20 | call random_seed(put=seed_put) 21 | return 22 | end procedure rng 23 | 24 | end submodule forlab_stats_rng 25 | -------------------------------------------------------------------------------- /src/forlab_stats_std.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_stats) forlab_stats_var 3 | 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure var_1_sp 9 | integer :: opt_w 10 | 11 | opt_w = 0 12 | if (present(w)) opt_w = w 13 | select case (opt_w) 14 | case (0) 15 | var_1_sp = sum((x - mean(x))**2)/(size(x) - 1) 16 | case (1) 17 | var_1_sp = sum((x - mean(x))**2)/size(x) 18 | end select 19 | return 20 | end procedure var_1_sp 21 | 22 | module procedure var_2_sp 23 | integer :: opt_w, i, m, n 24 | 25 | opt_w = 0 26 | if (present(w)) opt_w = w 27 | m = size(A, 1) 28 | n = size(A, 2) 29 | if ((.not. present(dim)) .or. (dim == 1)) then 30 | allocate (var_2_sp(n)) 31 | do i = 1, n 32 | var_2_sp(i) = var_1_sp(A(:, i), opt_w) 33 | end do 34 | elseif (dim == 2) then 35 | allocate (var_2_sp(m)) 36 | do i = 1, m 37 | var_2_sp(i) = var_1_sp(A(i, :), opt_w) 38 | end do 39 | end if 40 | return 41 | end procedure var_2_sp 42 | module procedure var_1_dp 43 | integer :: opt_w 44 | 45 | opt_w = 0 46 | if (present(w)) opt_w = w 47 | select case (opt_w) 48 | case (0) 49 | var_1_dp = sum((x - mean(x))**2)/(size(x) - 1) 50 | case (1) 51 | var_1_dp = sum((x - mean(x))**2)/size(x) 52 | end select 53 | return 54 | end procedure var_1_dp 55 | 56 | module procedure var_2_dp 57 | integer :: opt_w, i, m, n 58 | 59 | opt_w = 0 60 | if (present(w)) opt_w = w 61 | m = size(A, 1) 62 | n = size(A, 2) 63 | if ((.not. present(dim)) .or. (dim == 1)) then 64 | allocate (var_2_dp(n)) 65 | do i = 1, n 66 | var_2_dp(i) = var_1_dp(A(:, i), opt_w) 67 | end do 68 | elseif (dim == 2) then 69 | allocate (var_2_dp(m)) 70 | do i = 1, m 71 | var_2_dp(i) = var_1_dp(A(i, :), opt_w) 72 | end do 73 | end if 74 | return 75 | end procedure var_2_dp 76 | module procedure std_1_sp 77 | integer :: opt_w 78 | 79 | opt_w = 0 80 | if (present(w)) opt_w = w 81 | std_1_sp = sqrt(var_1_sp(x, opt_w)) 82 | return 83 | end procedure std_1_sp 84 | 85 | module procedure std_2_sp 86 | integer :: opt_w 87 | 88 | opt_w = 0 89 | if (present(w)) opt_w = w 90 | if (.not. present(dim)) then 91 | std_2_sp = sqrt(var_2_sp(A, opt_w)) 92 | else 93 | std_2_sp = sqrt(var_2_sp(A, opt_w, dim)) 94 | end if 95 | return 96 | end procedure std_2_sp 97 | module procedure std_1_dp 98 | integer :: opt_w 99 | 100 | opt_w = 0 101 | if (present(w)) opt_w = w 102 | std_1_dp = sqrt(var_1_dp(x, opt_w)) 103 | return 104 | end procedure std_1_dp 105 | 106 | module procedure std_2_dp 107 | integer :: opt_w 108 | 109 | opt_w = 0 110 | if (present(w)) opt_w = w 111 | if (.not. present(dim)) then 112 | std_2_dp = sqrt(var_2_dp(A, opt_w)) 113 | else 114 | std_2_dp = sqrt(var_2_dp(A, opt_w, dim)) 115 | end if 116 | return 117 | end procedure std_2_dp 118 | 119 | end submodule forlab_stats_var 120 | -------------------------------------------------------------------------------- /src/forlab_time.f90: -------------------------------------------------------------------------------- 1 | 2 | module forlab_time 3 | 4 | use forlab_io, only: disp 5 | use stdlib_kinds, only: sp, dp, qp, & 6 | int8, int16, int32, int64 7 | implicit none 8 | private 9 | 10 | public :: datenum, time_string 11 | public :: is_leap 12 | public :: tic, toc 13 | 14 | interface datenum 15 | real(dp) module function datenum0(year, month, day, hour, minute, & 16 | second, microsecond) 17 | integer, intent(in) :: year, month, day 18 | integer, intent(in), optional :: hour, minute, second, microsecond 19 | end function datenum0 20 | end interface datenum 21 | 22 | interface is_leap 23 | procedure :: is_leap_int8 24 | procedure :: is_leap_int16 25 | procedure :: is_leap_int32 26 | procedure :: is_leap_int64 27 | end interface is_leap 28 | 29 | interface 30 | module subroutine tic() 31 | end subroutine tic 32 | end interface 33 | 34 | interface toc 35 | module subroutine toc_default() 36 | end subroutine toc_default 37 | module subroutine toc_sp(time) 38 | real(sp), intent(out) :: time 39 | end subroutine toc_sp 40 | module subroutine toc_dp(time) 41 | real(dp), intent(out) :: time 42 | end subroutine toc_dp 43 | end interface toc 44 | 45 | contains 46 | 47 | logical function is_leap_int8(year) result(is_leap) 48 | integer(int8), intent(in) :: year 49 | if ((mod(year, 400) == 0) .or. & 50 | ((mod(year, 4) == 0) .and. (mod(year, 100) /= 0))) then 51 | is_leap = .true. 52 | else 53 | is_leap = .false. 54 | end if 55 | return 56 | end function is_leap_int8 57 | logical function is_leap_int16(year) result(is_leap) 58 | integer(int16), intent(in) :: year 59 | if ((mod(year, 400) == 0) .or. & 60 | ((mod(year, 4) == 0) .and. (mod(year, 100) /= 0))) then 61 | is_leap = .true. 62 | else 63 | is_leap = .false. 64 | end if 65 | return 66 | end function is_leap_int16 67 | logical function is_leap_int32(year) result(is_leap) 68 | integer(int32), intent(in) :: year 69 | if ((mod(year, 400) == 0) .or. & 70 | ((mod(year, 4) == 0) .and. (mod(year, 100) /= 0))) then 71 | is_leap = .true. 72 | else 73 | is_leap = .false. 74 | end if 75 | return 76 | end function is_leap_int32 77 | logical function is_leap_int64(year) result(is_leap) 78 | integer(int64), intent(in) :: year 79 | if ((mod(year, 400) == 0) .or. & 80 | ((mod(year, 4) == 0) .and. (mod(year, 100) /= 0))) then 81 | is_leap = .true. 82 | else 83 | is_leap = .false. 84 | end if 85 | return 86 | end function is_leap_int64 87 | 88 | character(19) function time_string() 89 | implicit none 90 | character(10) :: data, time 91 | call date_and_time(data, time) 92 | time_string = data(1:4)//'-'//data(5:6)//'-'//data(7:8)//' '//time(1:2) & 93 | //':'//time(3:4)//':'//time(5:6) 94 | end function time_string 95 | 96 | end module forlab_time 97 | -------------------------------------------------------------------------------- /src/forlab_time_datenum.f90: -------------------------------------------------------------------------------- 1 | submodule(forlab_time) forlab_time_datenum 2 | 3 | use stdlib_strings, only: to_string 4 | implicit none 5 | 6 | contains 7 | 8 | module procedure datenum0 9 | integer :: i, days_per_month(12) 10 | 11 | if ((month .lt. 1) .and. (month .gt. 12)) then 12 | call disp("Error: month should be between 1 and 12 ("//to_string(month)//").") 13 | end if 14 | if ((day .lt. 1) .and. (day .gt. 31)) then 15 | call disp("Error: day should be between 1 and 31 ("//to_string(day)//").") 16 | end if 17 | if ((present(hour)) .and. (hour .lt. 0) .and. (hour .gt. 23)) then 18 | call disp("Error: hour should be between 0 and 23 ("//to_string(hour)//").") 19 | end if 20 | if ((present(minute)) .and. (minute .lt. 0) .and. (minute .gt. 59)) then 21 | call disp("Error: minute should be between 0 and 59 ("//to_string(minute)//").") 22 | end if 23 | if ((present(second)) .and. (second .lt. 0) .and. (second .gt. 59)) then 24 | call disp("Error: second should be between 0 and 59 ("//to_string(second)//").") 25 | end if 26 | if ((present(microsecond)) .and. (microsecond .lt. 0) .and. (microsecond .ge. 1.0d+6)) then 27 | call disp("Error: microsecond should be between 0 and 999,999 ("//to_string(microsecond)//").") 28 | end if 29 | days_per_month = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] 30 | datenum0 = 0 31 | do i = 0, year - 1 32 | if (is_leap(i)) then 33 | datenum0 = datenum0 + 366 34 | else 35 | datenum0 = datenum0 + 365 36 | end if 37 | end do 38 | datenum0 = datenum0 + sum(days_per_month(:month - 1)) 39 | if (is_leap(year) .and. (month .gt. 2)) datenum0 = datenum0 + 1 40 | datenum0 = datenum0 + day 41 | if (present(hour)) datenum0 = datenum0 + real(hour, kind=8)/24.0d0 42 | if (present(minute)) datenum0 = datenum0 + real(minute, kind=8)/(24.0d0*60.0d0) 43 | if (present(second)) datenum0 = datenum0 + real(second, kind=8)/(24.0d0*60.0d0*60.0d0) 44 | if (present(microsecond)) datenum0 = datenum0 + real(microsecond, kind=8)/(24.0d0*60.0d0*60.0d0*1.0d+6) 45 | return 46 | end procedure datenum0 47 | 48 | end submodule forlab_time_datenum 49 | -------------------------------------------------------------------------------- /src/forlab_time_tioc.f90: -------------------------------------------------------------------------------- 1 | 2 | submodule(forlab_time) forlab_time_tioc 3 | 4 | use stdlib_strings, only: to_string 5 | implicit none 6 | real(dp), save :: tic_time 7 | 8 | contains 9 | module procedure tic 10 | integer :: values(8) 11 | call date_and_time(values=values) 12 | tic_time = datenum(values(1), values(2), values(3), values(5), & 13 | values(6), values(7), values(8)*1000) & 14 | *24.0d0*60.0d0*60.0d0 15 | return 16 | end procedure tic 17 | 18 | module procedure toc_default 19 | integer :: values(8) 20 | real(dp) :: toc_time, elapsed_time 21 | 22 | call date_and_time(values=values) 23 | toc_time = datenum(values(1), values(2), values(3), values(5), & 24 | values(6), values(7), values(8)*1000) & 25 | *24.0d0*60.0d0*60.0d0 26 | elapsed_time = toc_time - tic_time 27 | 28 | call disp("Elapsed time: " & 29 | //to_string(elapsed_time, "(F12.3)") & 30 | //" seconds") 31 | return 32 | end procedure toc_default 33 | 34 | module procedure toc_sp 35 | integer :: values(8) 36 | real(dp) :: toc_time, elapsed_time 37 | 38 | call date_and_time(values=values) 39 | toc_time = datenum(values(1), values(2), values(3), values(5), & 40 | values(6), values(7), values(8)*1000) & 41 | *24.0d0*60.0d0*60.0d0 42 | elapsed_time = toc_time - tic_time 43 | 44 | time = elapsed_time !!\ATTENTION@zuo.zhihua@qq.com: Accuracy is converted here. 45 | return 46 | end procedure toc_sp 47 | module procedure toc_dp 48 | integer :: values(8) 49 | real(dp) :: toc_time, elapsed_time 50 | 51 | call date_and_time(values=values) 52 | toc_time = datenum(values(1), values(2), values(3), values(5), & 53 | values(6), values(7), values(8)*1000) & 54 | *24.0d0*60.0d0*60.0d0 55 | elapsed_time = toc_time - tic_time 56 | 57 | time = elapsed_time !!\ATTENTION@zuo.zhihua@qq.com: Accuracy is converted here. 58 | return 59 | end procedure toc_dp 60 | 61 | end submodule forlab_time_tioc 62 | -------------------------------------------------------------------------------- /test/checker.f90: -------------------------------------------------------------------------------- 1 | !> new Unit-Test 2 | 3 | program checker 4 | 5 | use test_math, only: collect_math 6 | use, intrinsic :: iso_fortran_env, only: error_unit 7 | use testdrive, only: run_testsuite, new_testsuite, testsuite_type 8 | implicit none 9 | integer :: stat, is 10 | type(testsuite_type), allocatable :: testsuites(:) 11 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 12 | 13 | stat = 0 14 | 15 | testsuites = [& 16 | new_testsuite("test_math", collect_math)& 17 | ] 18 | 19 | do is = 1, size(testsuites) 20 | write (error_unit, fmt) "Testing:", testsuites(is)%name 21 | call run_testsuite(testsuites(is)%collect, error_unit, stat) 22 | end do 23 | 24 | if (stat > 0) then 25 | write (error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 26 | error stop 27 | end if 28 | 29 | end program checker -------------------------------------------------------------------------------- /test/io/test_io_bin.f90: -------------------------------------------------------------------------------- 1 | program test_io_bin 2 | use forlab_io, only: disp, savebin, loadbin, savetxt, loadtxt 3 | use forlab_stats, only: rng, randn 4 | real(8), allocatable :: x(:) 5 | real(8), allocatable :: y(:) 6 | call rng() 7 | allocate(X(5)) 8 | X = randn(mean=0.0_8, std=1.0_8, ndim=5) 9 | call disp(x,'call randn(X):') 10 | call savebin('DP.bin', x) 11 | call savetxt('DP.txt', x) 12 | call loadtxt('DP.txt', y) 13 | call disp(y,'read from DP.txt') 14 | call loadbin('DP.bin', y) 15 | call disp(y,'read from DP.bin') 16 | end program test_io_bin -------------------------------------------------------------------------------- /test/io/test_io_color.f90: -------------------------------------------------------------------------------- 1 | !> This is not a test. 2 | program test_io_color 3 | use forlab_io, only: color 4 | use iso_fortran_env, only: compiler_version 5 | use forlab_color, only: green, red 6 | 7 | call color(green) 8 | print *, compiler_version() 9 | 10 | print *, red // compiler_version() 11 | 12 | call color() 13 | print *, compiler_version() 14 | 15 | end program test_io_color 16 | -------------------------------------------------------------------------------- /test/io/test_io_file.f90: -------------------------------------------------------------------------------- 1 | program test_io_file 2 | use forlab_io, only: file, disp 3 | use stdlib_error, only: check 4 | type(file) :: infile 5 | 6 | infile = file('./test/io/test_io_file.f90', 'r') 7 | call check(infile%exist(), msg='Error: File not exist, '//infile%filename) 8 | call infile%open() 9 | call infile%countlines() 10 | call disp(infile%lines, 'Linenumber in file is: ') 11 | call check(infile%lines == 14, msg="`test_io_file` failed.") 12 | call infile%close() 13 | 14 | end program test_io_file -------------------------------------------------------------------------------- /test/io/test_io_read_line.f90: -------------------------------------------------------------------------------- 1 | program main 2 | 3 | use forlab_io, only: read_line, read_file 4 | implicit none 5 | integer :: unit 6 | character(:), allocatable :: line 7 | 8 | open(newunit=unit, file="test/io/test_io_read_line.f90") 9 | call read_line(line, unit) 10 | print *, line, len(line) 11 | 12 | call read_file(line, "test/io/test_io_read_line.f90") 13 | print *, line, len(line) 14 | 15 | call read_file(line, "test/io/test_io_read_line.f90", keep_newline=.false.) 16 | print *, line, len(line) 17 | 18 | end program main -------------------------------------------------------------------------------- /test/linalg/test_linalg_diff.f90: -------------------------------------------------------------------------------- 1 | program test_linalg_diff 2 | 3 | use forlab_linalg, only: diff 4 | use forlab_linalg, only: linspace, seq 5 | use forlab_io, only: disp 6 | implicit none 7 | 8 | real :: x(10) 9 | integer, allocatable :: i(:) 10 | 11 | call linspace(x, 0.0, 9.0) 12 | call disp("Test_linalg_diff_real : ") 13 | call disp(x, "Linspace(x) : ") 14 | call disp(diff(x), "Test_linalg_diff : ") 15 | 16 | call seq(i, 0, 9, 1) 17 | call disp("Test_linalg_diff_integer : ") 18 | call disp(i, "Seq(i) : ") 19 | call disp(diff(i), "Test_linalg_diff : ") 20 | 21 | end program test_linalg_diff -------------------------------------------------------------------------------- /test/linalg/test_linalg_i.f90: -------------------------------------------------------------------------------- 1 | program test_linalg_i 2 | use forlab_linalg, only: operator(.i.) 3 | use forlab_io, only: disp 4 | ! test inv and solve equation Ax=b, A^(-1) * b 5 | real :: a(2, 2) = reshape([1, 2, 3, 1], [2, 2]) 6 | real :: b(2) = [1, 1] 7 | call disp("Test Inv and solve equation Ax=b") 8 | call disp('A=') 9 | call disp(a) 10 | call disp("b=") 11 | call disp(b) 12 | call disp("x=") 13 | call disp(matmul(.i.a, b)) 14 | end program test_linalg_i -------------------------------------------------------------------------------- /test/linalg/test_linalg_linspace.f90: -------------------------------------------------------------------------------- 1 | program test_linalg_linspace 2 | use forlab_io, only: disp, file 3 | use forlab_linalg, only: linspace, logspace 4 | implicit none 5 | real :: x(4) 6 | call linspace(x, 1.0, 10.0) 7 | call disp(x, 'linspace(x, 1.0, 10.0) : ') 8 | call logspace(x, 1.0, 10.0) 9 | call disp(x, 'logspace(x, 1.0, 10.0) : ') 10 | end program test_linalg_linspace -------------------------------------------------------------------------------- /test/linalg/test_linalg_tri.f90: -------------------------------------------------------------------------------- 1 | program test_linalg_tri 2 | use forlab_linalg, only: tril, triu, ones 3 | use forlab_io, only: disp 4 | real :: X(4, 4) 5 | call disp("tri U L test") 6 | x = ones(4, 4) 7 | call disp(X, "A=") 8 | call disp(tril(X), "tril") 9 | call disp(triu(X), "triu") 10 | call disp(tril(X, -1), "tril") 11 | call disp(triu(X, 1), "triu") 12 | end program test_linalg_tri 13 | -------------------------------------------------------------------------------- /test/linalg/test_linalg_x.f90: -------------------------------------------------------------------------------- 1 | program test_linalg_x 2 | use forlab_linalg, only: operator(.x.) 3 | use forlab_io, only: disp 4 | real, dimension(:, :), allocatable :: x_sp, y_sp 5 | 6 | allocate(x_sp(2,2), y_sp(2,2)) 7 | 8 | x_sp = 1. 9 | y_sp = 2. 10 | 11 | call disp(x_sp.x.y_sp, 'x .x. y SP✨:') 12 | end program test_linalg_x -------------------------------------------------------------------------------- /test/linalg/test_linalg_zerosones.f90: -------------------------------------------------------------------------------- 1 | !> SPDX-Identifier: MIT 2 | module test_linalg_ones_zeros 3 | 4 | use forlab_linalg, only: zeros, ones 5 | use stdlib_error, only: check 6 | implicit none 7 | 8 | logical, parameter :: warn = .false. 9 | 10 | contains 11 | 12 | !> `zeros` tests 13 | subroutine test_linalg_zeros_integer 14 | call check(all(zeros(2) == [0, 0]), msg="all(zeros(2)==[0, 0] failed", warn=warn) 15 | call check(all(zeros(2, 2) == reshape([0, 0, 0, 0], [2, 2])), & 16 | msg="all(zeros(2,2)==reshape([0, 0, 0, 0],[2,2]) failed", warn=warn) 17 | end subroutine test_linalg_zeros_integer 18 | 19 | subroutine test_linalg_zeros_real 20 | real, allocatable :: rA(:), rB(:, :) 21 | rA = zeros(2) 22 | call check(all(rA == spread(0.0_4, 1, 2)), msg="all(rA == spread(0.0_4,1,2)) failed", warn=warn) 23 | rB = zeros(2, 2) 24 | call check(all(rB == reshape(spread(0.0_4, 1, 2*2), [2, 2])), & 25 | msg="all(rB == reshape(spread(0.0_4, 1,2*2),[2,2])) failed", warn=warn) 26 | end subroutine test_linalg_zeros_real 27 | 28 | subroutine test_linalg_zeros_complex 29 | complex, allocatable :: cA(:), cB(:, :) 30 | cA = zeros(2) 31 | call check(all(cA == spread((0.0_4, 0.0_4), 1, 2)), msg="all(cA == spread((0.0_4,0.0_4),1,2)) failed", warn=warn) 32 | cB = zeros(2, 2) 33 | call check(all(cB == reshape(spread((0.0_4, 0.0_4), 1, 2*2), [2, 2])), & 34 | msg="all(cB == reshape(spread((0.0_4,0.0_4), 1, 2*2), [2, 2])) failed", warn=warn) 35 | end subroutine test_linalg_zeros_complex 36 | 37 | !> `ones` tests 38 | subroutine test_linalg_ones_integer 39 | call check(all(ones(2) == [1, 1]), msg="all(ones(2)==[1, 1] failed", warn=warn) 40 | call check(all(ones(2, 2) == reshape([1, 1, 1, 1], [2, 2])), & 41 | msg="all(ones(2,2)==reshape([1, 1, 1, 1],[2,2])) failed", warn=warn) 42 | end subroutine test_linalg_ones_integer 43 | 44 | subroutine test_linalg_ones_real 45 | real, allocatable :: rA(:), rB(:, :) 46 | rA = ones(2) 47 | call check(all(rA == spread(1.0_4, 1, 2)), msg="all(rA == spread(1.0_4,1,2)) failed", warn=warn) 48 | rB = ones(2, 2) 49 | call check(all(rB == reshape(spread(1.0_4, 1, 2*2), [2, 2])), & 50 | msg="all(rB == reshape(spread(1.0_4, 1, 2*2), [2, 2])) failed", warn=warn) 51 | end subroutine test_linalg_ones_real 52 | 53 | subroutine test_linalg_ones_complex 54 | complex, allocatable :: cA(:), cB(:, :) 55 | cA = ones(2) 56 | call check(all(cA == spread((1.0_4, 0.0_4), 1, 2)), msg="all(cA == spread((1.0_4,0.0_4),1,2)) failed", warn=warn) 57 | cB = ones(2, 2) 58 | call check(all(cB == reshape(spread((1.0_4, 0.0_4), 1, 2*2), [2, 2])), & 59 | msg="all(cB == reshape(spread((1.0_4, 0.0_4), 1, 2*2), [2, 2])) failed", warn=warn) 60 | end subroutine test_linalg_ones_complex 61 | 62 | end module test_linalg_ones_zeros 63 | 64 | program tester 65 | 66 | use test_linalg_ones_zeros 67 | 68 | print *, "`zeros` tests: " 69 | call test_linalg_zeros_integer 70 | call test_linalg_zeros_real 71 | call test_linalg_zeros_complex 72 | 73 | print *, "`ones ` tests: " 74 | call test_linalg_ones_integer 75 | call test_linalg_ones_real 76 | call test_linalg_ones_complex 77 | 78 | print *, "All tests in `test_linalg_ones_zeros` passed." 79 | 80 | end program tester 81 | -------------------------------------------------------------------------------- /test/math/test_math_all_close.f90: -------------------------------------------------------------------------------- 1 | program tester 2 | 3 | use forlab_math, only: all_close 4 | use stdlib_error, only: check 5 | implicit none 6 | 7 | call test_math_all_close_real 8 | call test_math_all_close_complex 9 | print *, "All tests in `test_math_all_close` passed." 10 | 11 | contains 12 | 13 | subroutine test_math_all_close_real 14 | 15 | real :: x(4, 4), random(4, 4) 16 | 17 | call random_number(random) 18 | x = 1.0 19 | 20 | call check(all_close(x+1.0e-11*random, x), msg="REAL: all_close(x+1.0e-11*random, x) failed.") 21 | call check(all_close(x+1.0e-5 *random, x), msg="REAL: all_close(x+1.0e-5 *random, x) failed.", warn=.true.) 22 | 23 | end subroutine test_math_all_close_real 24 | 25 | subroutine test_math_all_close_complex 26 | 27 | real :: random(4, 4) 28 | complex :: x(4, 4) 29 | 30 | call random_number(random) 31 | x = 1.0 32 | 33 | call check(all_close(x+1.0e-11*random, x), msg="CMPLX: all_close(x+1.0e-11*random, x)") 34 | call check(all_close(x+1.0e-5 *random, x), msg="CMPLX: all_close(x+1.0e-5 *random, x) failed.", warn=.true.) 35 | 36 | end subroutine test_math_all_close_complex 37 | 38 | end program tester -------------------------------------------------------------------------------- /test/math/test_math_angle.f90: -------------------------------------------------------------------------------- 1 | program test_math_angle 2 | use forlab_math, only: angle 3 | use stdlib_kinds, only: sp 4 | implicit none 5 | complex(sp) :: c, cX(2) 6 | 7 | c = (1.0, 2.0) 8 | cX = (2.0, 3.0) 9 | 10 | print *, angle(c) 11 | print *, angle(cX) 12 | 13 | end program test_math_angle -------------------------------------------------------------------------------- /test/math/test_math_arange.f90: -------------------------------------------------------------------------------- 1 | !> SPDX-Identifier: MIT 2 | module test_math_arange 3 | 4 | use stdlib_error, only: check 5 | use forlab_math, only: arange 6 | 7 | logical, private :: warn = .false. 8 | 9 | contains 10 | 11 | subroutine test_math_arange_real 12 | !> Normal 13 | call check(all(arange(3.0) == [1.0, 2.0, 3.0]), msg="all(arange(3.0) == [1.0,2.0,3.0]) failed.", warn=warn) 14 | call check(all(arange(-1.0) == [1.0, 0.0, -1.0]), msg="all(arange(-1.0) == [1.0,0.0,-1.0]) failed.", warn=warn) 15 | call check(all(arange(0.0, 2.0) == [0.0, 1.0, 2.0]), msg="all(arange(0.0,2.0) == [0.0,1.0,2.0]) failed.", warn=warn) 16 | call check(all(arange(1.0, -1.0) == [1.0, 0.0, -1.0]), msg="all(arange(1.0,-1.0) == [1.0,0.0,-1.0]) failed.", warn=warn) 17 | call check(all(arange(1.0, 1.0) == [1.0]), msg="all(arange(1.0,1.0) == [1.0]) failed.", warn=warn) 18 | call check(all(arange(0.0, 2.0, 2.0) == [0.0, 2.0]), msg="all(arange(0.0,2.0,2.0) == [0.0,2.0]) failed.", warn=warn) 19 | call check(all(arange(1.0, -1.0, 2.0) == [1.0, -1.0]), msg="all(arange(1.0,-1.0,2.0) == [1.0,-1.0]) failed.", warn=warn) 20 | !> Not recommended 21 | call check(all(arange(0.0, 2.0, -2.0) == [0.0, 2.0]), msg="all(arange(0.0,2.0,-2.0) == [0.0,2.0]) failed.", warn=warn) 22 | call check(all(arange(1.0, -1.0, -2.0) == [1.0, -1.0]),msg="all(arange(1.0,-1.0,-2.0) == [1.0,-1.0]) failed.", warn=warn) 23 | call check(all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]),msg="all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]) failed.", warn=warn) 24 | end subroutine test_math_arange_real 25 | 26 | subroutine test_math_arange_integer 27 | !> Normal 28 | call check(all(arange(3) == [1, 2, 3]), msg="all(arange(3) == [1,2,3]) failed.", warn=warn) 29 | call check(all(arange(-1) == [1, 0, -1]), msg="all(arange(-1) == [1,0,-1]) failed.", warn=warn) 30 | call check(all(arange(0, 2) == [0, 1, 2]), msg="all(arange(0,2) == [0,1,2]) failed.", warn=warn) 31 | call check(all(arange(1, -1) == [1, 0, -1]), msg="all(arange(1,-1) == [1,0,-1]) failed.", warn=warn) 32 | call check(all(arange(1, 1) == [1]), msg="all(arange(1,1) == [1]) failed.", warn=warn) 33 | call check(all(arange(0, 2, 2) == [0, 2]), msg="all(arange(0,2,2) == [0,2]) failed.", warn=warn) 34 | call check(all(arange(1, -1, 2) == [1, -1]), msg="all(arange(1,-1,2) == [1,-1]) failed.", warn=warn) 35 | !> Not recommended 36 | call check(all(arange(0, 2, -2) == [0, 2]), msg="all(arange(0,2,-2) == [0,2]) failed.", warn=warn) 37 | call check(all(arange(1, -1, -2) == [1, -1]), msg="all(arange(1,-1,-2) == [1,-1]) failed.", warn=warn) 38 | call check(all(arange(0, 2, 0) == [0,1,2]), msg="all(arange(0, 2, 0) == [0,1,2]) failed.", warn=warn) 39 | end subroutine test_math_arange_integer 40 | 41 | end module test_math_arange 42 | 43 | program tester 44 | 45 | use test_math_arange 46 | 47 | call test_math_arange_real 48 | call test_math_arange_integer 49 | 50 | print *, "All tests in `test_math_arange` passed." 51 | 52 | end program tester -------------------------------------------------------------------------------- /test/math/test_math_degcir.f90: -------------------------------------------------------------------------------- 1 | program test_math_degcir 2 | use forlab_math, only: acosd, tand 3 | use forlab_io, only: disp 4 | ! test degrees circular function 5 | call disp('Test degrees circular function') 6 | call disp("acosd(1.d0)=") 7 | call disp(acosd(1.d0)) 8 | call disp("tand([45.0,60.0,0.0])") 9 | call disp(tand([45.0, 60.0, 0.0])) 10 | end program test_math_degcir 11 | -------------------------------------------------------------------------------- /test/math/test_math_is_close.f90: -------------------------------------------------------------------------------- 1 | program test_math_is_close 2 | 3 | call test_math_is_close_real 4 | call test_math_is_close_complex 5 | print *, "All tests in `test_math_is_close` passed." 6 | 7 | contains 8 | 9 | subroutine test_math_is_close_real 10 | use forlab_math, only: is_close 11 | use stdlib_error, only: check 12 | 13 | call check(is_close(2.5, 2.5, rel_tol=1.0e-5), msg="is_close(2.5, 2.5, rel_tol=1.0e-5) failed.") 14 | call check(all(is_close([2.5, 3.2], [2.5, 10.0], rel_tol=1.0e-5)), & 15 | msg="all(is_close([2.5, 3.2], [2.5, 10.0], rel_tol=1.0e-5)) failed (expected).", warn=.true.) 16 | call check(all(is_close(reshape([2.5, 3.2, 2.2, 1.0], [2, 2]), reshape([2.5, 3.2001, 2.25, 1.1], [2, 2]), & 17 | abs_tol=1.0e-5, rel_tol=0.1)), & 18 | msg="all(is_close(reshape([2.5, 3.2, 2.2, 1.0],[2,2]), reshape([2.5, 3.2001, 2.25, 1.1],[2,2]), & 19 | &rel_tol=1.0e-5, abs_tol=0.1)) failed.") 20 | 21 | !> Tests for zeros 22 | call check(is_close(0.0, -0.0), msg="is_close(0.0, -0.0) failed.") 23 | 24 | end subroutine test_math_is_close_real 25 | 26 | subroutine test_math_is_close_complex 27 | use forlab_math, only: is_close 28 | use stdlib_error, only: check 29 | 30 | call check(is_close((2.5,1.2), (2.5,1.2), rel_tol=1.0e-5), & 31 | msg="is_close((2.5,1.2), (2.5,1.2), rel_tol=1.0e-5) failed.") 32 | call check(all(is_close([(2.5,1.2), (3.2,1.2)], [(2.5,1.2), (10.0,1.2)], rel_tol=1.0e-5)), & 33 | msg="all(is_close([(2.5,1.2), (3.2,1.2)], [(2.5,1.2), (10.0,1.2)], rel_tol=1.0e-5)) failed (expected).", & 34 | warn=.true.) 35 | call check(all(is_close(reshape([(2.5,1.2009), (3.2,1.199999)], [1, 2]), reshape([(2.4,1.2009), (3.15,1.199999)], [1, 2]), & 36 | abs_tol=1.0e-5, rel_tol=0.1)), & 37 | msg="all(is_close(reshape([(2.5,1.2009), (3.2,1.199999)], [1, 2]), & 38 | &reshape([(2.4,1.2009), (3.15,1.199999)], [1, 2]), & 39 | &rel_tol=1.0e-5, abs_tol=0.1)) failed.") 40 | 41 | !> Tests for zeros 42 | call check(is_close((0.0, -0.0), (-0.0, 0.0)), msg="is_close((0.0, -0.0), (-0.0, 0.0)) failed.") 43 | 44 | end subroutine test_math_is_close_complex 45 | 46 | end program test_math_is_close -------------------------------------------------------------------------------- /test/math/test_math_signum.f90: -------------------------------------------------------------------------------- 1 | module test_math_signum 2 | 3 | use forlab_math, only: signum, is_close 4 | use stdlib_error, only: check 5 | 6 | contains 7 | 8 | subroutine test_math_signum_real 9 | 10 | real :: x(3) = [-2.0, 0.0, 3.0] 11 | call check(all(is_close(signum(x), [-1.0, 0.0, 1.0])), "signum for `real` failed.") 12 | 13 | end subroutine test_math_signum_real 14 | 15 | subroutine test_math_signum_integer 16 | 17 | integer :: x(3) = [-2, 0, 3] 18 | call check(all(signum(x) == [-1, 0, 1]), "signum for `integer` failed.") 19 | 20 | end subroutine test_math_signum_integer 21 | 22 | subroutine test_math_signum_complex 23 | 24 | complex :: x(3) = [(-2.0, 1.0), (0.0, 0.0), (3.0, 4.0)] 25 | call check(all(is_close(signum(x), [(-0.894427180, 0.447213590), (0.0, 0.0), (0.600000024, 0.800000012)])), & 26 | "signum for `complex` failed.") 27 | 28 | end subroutine test_math_signum_complex 29 | 30 | end module test_math_signum 31 | 32 | program tester 33 | 34 | use test_math_signum 35 | call test_math_signum_real 36 | call test_math_signum_integer 37 | call test_math_signum_complex 38 | print *, "All tests in `test_math_signum` passed." 39 | 40 | end program tester 41 | -------------------------------------------------------------------------------- /test/sorting/test_sorting_sort.f90: -------------------------------------------------------------------------------- 1 | program test_sorting_sort 2 | use forlab_sorting,only:argsort,sort 3 | use forlab_io, only:disp 4 | real(8)::x(4) 5 | integer::a(4)=[1,3,2,4] 6 | call random_number(x) 7 | call disp("argsort/sort tri U L test") 8 | call disp(x,"x") 9 | call disp(argsort(x),"argsort(x)") 10 | call disp(argsort(x,2),"argsort(x)") 11 | call disp(sort(x,2),"sort(x)") 12 | call disp(sort(x,1),"sort(x)") 13 | call disp(a,"x") 14 | call disp(argsort(a),"argsort(a)") 15 | call disp(argsort(a,2),"argsort(a)") 16 | call disp(sort(a,2),"sort(a)") 17 | call disp(sort(a,1),"sort(a)") 18 | end program test_sorting_sort -------------------------------------------------------------------------------- /test/stats/stats_checker.f90: -------------------------------------------------------------------------------- 1 | program stats_checker 2 | 3 | use test_stats_randu 4 | use test_stats_randn 5 | 6 | call test_stats_randu_integer 7 | call test_stats_randu_real 8 | print *, "** All tests in `test_stats_randu` passed." 9 | 10 | call test_stats_randn_real 11 | print *, "** All tests in `test_stats_randn` passed." 12 | 13 | end program stats_checker -------------------------------------------------------------------------------- /test/stats/test_stats_rand.f90: -------------------------------------------------------------------------------- 1 | program test_stats_rand 2 | use forlab_stats, only: rng, randu, randn 3 | use forlab_io, only: disp 4 | implicit none 5 | integer(kind=4) :: iX(5) 6 | real(kind=8) :: rX(5) 7 | 8 | call rng() 9 | call randu(iX) 10 | call disp(iX, 'RANDU(iX(5)) : ') 11 | call randu(iX, from=-10_4, to=10_4) 12 | call disp(iX, 'RANDU(iX, from=-10_4, to=10_4) : ') 13 | 14 | call randu(rX) 15 | call disp(rX, 'RANDU(rX(5)) : ') 16 | call randu(rX, from=-10.d0, to=10.d0) 17 | call disp(rX, 'RANDU(rX, from=-10.d0, to=10.d0) : ') 18 | 19 | call randn(rX) 20 | call disp(rX, 'RANDN(rX(5)) : ') 21 | call randn(rX, mean=0.d0, std=10.d0) 22 | call disp(rX, 'RANDN(rX, mean=0.d0, std=10.d0) : ') 23 | 24 | end program test_stats_rand -------------------------------------------------------------------------------- /test/stats/test_stats_randn.f90: -------------------------------------------------------------------------------- 1 | module test_stats_randn 2 | 3 | use forlab_stats, only: randn, mean 4 | use stdlib_error, only: check 5 | implicit none 6 | private 7 | 8 | public :: test_stats_randn_real 9 | 10 | contains 11 | 12 | subroutine test_stats_randn_real 13 | 14 | print *, "** checking `test_stats_randn_real`.." 15 | 16 | call check(mean(randn(mean=0.0, std=2.0, ndim=100)) <= 2.0, & 17 | msg="mean(randn(mean=0.0, std=2.0, ndim=10) <= 2.0) failed.") 18 | call check(mean(randn(mean=0.0, std=2.0, ndim=100)) >= -2.0, & 19 | msg="mean(randn(mean=0.0, std=2.0, ndim=10) >= -2.0) failed.") 20 | 21 | end subroutine test_stats_randn_real 22 | 23 | end module test_stats_randn 24 | -------------------------------------------------------------------------------- /test/stats/test_stats_randu.f90: -------------------------------------------------------------------------------- 1 | module test_stats_randu 2 | 3 | use forlab_stats, only: randu 4 | use stdlib_error, only: check 5 | implicit none 6 | private 7 | 8 | public :: test_stats_randu_integer, test_stats_randu_real 9 | 10 | contains 11 | 12 | subroutine test_stats_randu_real 13 | 14 | print *, "** checking `test_stats_randu_real`.." 15 | 16 | call check(randu(start=1.0, end=2.0) <= 2.0, msg="randu(start=1.0, end=2.0) <= 2.0 failed.") 17 | call check(randu(start=1.0, end=2.0) >= 1.0, msg="randu(start=1.0, end=2.0) >= 1.0 failed.") 18 | 19 | call check(all(randu(start=1.0, end=2.0, ndim=3) <= 2.0), msg="randu(start=1.0, end=2.0, ndim=3) <= 2.0 failed.") 20 | call check(all(randu(start=1.0, end=2.0, ndim=3) >= 1.0), msg="randu(start=1.0, end=2.0, ndim=3) >= 1.0 failed.") 21 | 22 | end subroutine test_stats_randu_real 23 | 24 | subroutine test_stats_randu_integer 25 | 26 | print *, "** checking `test_stats_randu_integer`.." 27 | 28 | call check(randu(start=1, end=2) <= 2, msg="randu(start=1, end=2) <= 2 failed.") 29 | call check(randu(start=1, end=2) >= 1, msg="randu(start=1, end=2) >= 1 failed.") 30 | 31 | call check(all(randu(start=1, end=2, ndim=3) <= 2), msg="randu(start=1, end=2, ndim=3) <= 2 failed.") 32 | call check(all(randu(start=1, end=2, ndim=3) >= 1), msg="randu(start=1, end=2, ndim=3) >= 1 failed.") 33 | 34 | end subroutine test_stats_randu_integer 35 | 36 | end module test_stats_randu -------------------------------------------------------------------------------- /test/stats/test_stats_var.f90: -------------------------------------------------------------------------------- 1 | program test_stats_var 2 | use forlab_io, only: disp 3 | use forlab_stats, only: var,randn,rng,mean,std 4 | real, allocatable :: x(:) 5 | call rng() 6 | allocate(X(5)) 7 | x = randn(mean=0.0, std=1.0, ndim=5) 8 | call disp(x,'randn(n)') 9 | call disp(mean(x),'mean(randn(n)):') 10 | call disp(var(x),'var(randn(n)):') 11 | call disp(std(x), 'std(randn(n)):') 12 | if(allocated(X)) deallocate(X) 13 | allocate(X(4)) !!\FIXME: 14 | x = randn(mean=10.0, std=1.0, ndim=4) 15 | call disp(X,'call randn(X,10.,1.0)') 16 | end program test_stats_var -------------------------------------------------------------------------------- /test/test_math.f90: -------------------------------------------------------------------------------- 1 | module test_math 2 | 3 | use testdrive, only: new_unittest, unittest_type, error_type, check 4 | use forlab_math, only: operator(.c.), all_close, angle, is_close 5 | use, intrinsic :: iso_fortran_env, only: int8 6 | implicit none 7 | private 8 | 9 | public :: collect_math 10 | 11 | contains 12 | 13 | subroutine collect_math(testsuite) 14 | type(unittest_type), allocatable, intent(out) :: testsuite(:) 15 | testsuite = [& 16 | new_unittest("angle_real vaild", test_math_angle_real), & 17 | new_unittest("cross_int vaild", test_math_cross_int), & 18 | new_unittest("cross_real vaild", test_math_cross_real) & 19 | ] 20 | end subroutine collect_math 21 | 22 | subroutine test_math_cross_int(error) 23 | type(error_type), allocatable, intent(out) :: error 24 | integer(int8), dimension(3) :: x, y 25 | x = 1_int8; y = 2_int8 26 | 27 | call check(error, all((x.c.y) == [integer(int8) :: 0, 0, 0])) 28 | if (allocated(error)) return 29 | 30 | end subroutine test_math_cross_int 31 | 32 | subroutine test_math_cross_real(error) 33 | type(error_type), allocatable, intent(out) :: error 34 | real, dimension(3) :: x, y 35 | x = 1_int8; y = 2_int8 36 | 37 | call check(error, all_close((x.c.y), [real :: 0, 0, 0])) 38 | if (allocated(error)) return 39 | 40 | end subroutine test_math_cross_real 41 | 42 | module subroutine test_math_angle_real(error) 43 | type(error_type), allocatable, intent(out) :: error 44 | real, dimension(3) :: x, y 45 | x = 1_int8; y = 2_int8 46 | 47 | call check(error, is_close(angle(x, y), 0.0)) 48 | if (allocated(error)) return 49 | 50 | end subroutine test_math_angle_real 51 | 52 | end module test_math -------------------------------------------------------------------------------- /test/time/test_time_tioc.f90: -------------------------------------------------------------------------------- 1 | program test_time_tioc 2 | use forlab_time, only: tic, toc 3 | use forlab_io, only: disp 4 | use forlab_stats, only: rng, randn 5 | real :: time_sp 6 | real(8) :: time_dp 7 | real(8), allocatable :: x(:) 8 | 9 | call disp('----------------------------') 10 | call tic() 11 | allocate(x(1000)) 12 | x = randn(mean=0.0, std=1.0, ndim=1000) 13 | call disp(size(x), 'x size:') 14 | 15 | call toc() 16 | call toc(time_sp) 17 | call disp(time_sp, 'tic/toc sp-version is passed:') 18 | 19 | call toc() 20 | call toc(time_dp) 21 | call disp(time_dp, 'tic/toc dp-version is passed:') 22 | 23 | end program test_time_tioc --------------------------------------------------------------------------------