├── media ├── logo.png └── logo.svg ├── codecov.yml ├── fortran_function_parser.code-workspace ├── .gitignore ├── fpm.toml ├── fortran_function_parser.md ├── .github └── workflows │ └── CI.yml ├── LICENSE ├── src ├── error_module.f90 └── function_parser.F90 ├── README.md └── test └── tests.f90 /media/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jacobwilliams/fortran_function_parser/HEAD/media/logo.png -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: 2 | layout: header, changes, diff, sunburst 3 | coverage: 4 | ignore: 5 | - test 6 | - doc 7 | status: 8 | patch: 9 | default: 10 | target: 20% 11 | project: 12 | default: 13 | target: 60% 14 | -------------------------------------------------------------------------------- /fortran_function_parser.code-workspace: -------------------------------------------------------------------------------- 1 | { 2 | "folders": [ 3 | { 4 | "path": "." 5 | } 6 | ], 7 | "settings": { 8 | "files.trimTrailingWhitespace": true, 9 | "editor.insertSpaces": true, 10 | "editor.tabSize": 4, 11 | "editor.trimAutoWhitespace": true 12 | } 13 | } -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Compiled Object files 2 | *.slo 3 | *.lo 4 | *.o 5 | *.obj 6 | 7 | # Precompiled Headers 8 | *.gch 9 | *.pch 10 | 11 | # Compiled Dynamic libraries 12 | *.so 13 | *.dylib 14 | *.dll 15 | 16 | # Fortran module files 17 | *.mod 18 | 19 | # Compiled Static libraries 20 | *.lai 21 | *.la 22 | *.a 23 | *.lib 24 | 25 | # Executables 26 | *.exe 27 | *.out 28 | *.app 29 | 30 | # Directories 31 | build 32 | doc 33 | lib 34 | bin 35 | 36 | # misc 37 | .DS_Store -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "fortran_function_parser" 2 | license = "BSD-3-Clause" 3 | author = "Jacob Williams" 4 | maintainer = "https://github.com/jacobwilliams" 5 | copyright = "Copyright (c) 2017-2022, Jacob Williams" 6 | description = "Modern Fortran Function Parser" 7 | homepage = "https://github.com/jacobwilliams/fortran_function_parser" 8 | keywords = ["parser"] 9 | 10 | [library] 11 | source-dir = "src" 12 | 13 | [install] 14 | library = true 15 | 16 | [build] 17 | auto-executables = false 18 | auto-examples = false 19 | auto-tests = true -------------------------------------------------------------------------------- /fortran_function_parser.md: -------------------------------------------------------------------------------- 1 | project: fortran_function_parser 2 | project_dir: ./src 3 | output_dir: ./doc 4 | media_dir: ./media 5 | project_github: https://github.com/jacobwilliams/fortran_function_parser 6 | summary: Modern Fortran Function Parser 7 | author: Jacob Williams 8 | github: https://github.com/jacobwilliams 9 | predocmark_alt: > 10 | predocmark: < 11 | docmark_alt: 12 | docmark: ! 13 | display: public 14 | protected 15 | source: true 16 | graph: true 17 | extra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html 18 | 19 | {!README.md!} 20 | -------------------------------------------------------------------------------- /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push, pull_request] 3 | jobs: 4 | 5 | Build: 6 | runs-on: ${{ matrix.os }} 7 | strategy: 8 | fail-fast: false 9 | matrix: 10 | os: [ubuntu-latest] 11 | gcc_v: [10] # Version of GFortran we want to use. 12 | python-version: [3.9] 13 | env: 14 | FC: gfortran-${{ matrix.gcc_v }} 15 | GCC_V: ${{ matrix.gcc_v }} 16 | 17 | steps: 18 | - name: Checkout code 19 | uses: actions/checkout@v3.0.2 20 | with: 21 | submodules: recursive 22 | 23 | - name: Set up Python 3.x 24 | uses: actions/setup-python@v1 # Use pip to install latest CMake, & FORD/Jin2For, etc. 25 | with: 26 | python-version: ${{ matrix.python-version }} 27 | 28 | - name: Setup Graphviz 29 | uses: ts-graphviz/setup-graphviz@v1 30 | 31 | - name: Setup Fortran Package Manager 32 | uses: fortran-lang/setup-fpm@v4 33 | with: 34 | github-token: ${{ secrets.GITHUB_TOKEN }} 35 | 36 | - name: Install Python dependencies 37 | if: contains( matrix.os, 'ubuntu') 38 | run: | 39 | python -m pip install --upgrade pip 40 | pip install matplotlib ford 41 | if [ -f requirements.txt ]; then pip install -r requirements.txt; fi 42 | 43 | - name: Install GFortran Linux 44 | if: contains( matrix.os, 'ubuntu') 45 | run: | 46 | sudo apt-get install lcov 47 | sudo update-alternatives \ 48 | --install /usr/bin/gcc gcc /usr/bin/gcc-${{ matrix.gcc_v }} 100 \ 49 | --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${{ matrix.gcc_v }} \ 50 | --slave /usr/bin/gcov gcov /usr/bin/gcov-${{ matrix.gcc_v }} 51 | 52 | # - name: Compile 53 | # run: fpm build --profile release 54 | 55 | - name: Run tests 56 | run: fpm test --profile debug --flag -coverage 57 | 58 | - name: Create coverage report 59 | run: | 60 | mkdir -p ${{ env.COV_DIR }} 61 | lcov --capture --initial --base-directory . --directory build/gfortran_*/ --output-file ${{ env.COV_DIR }}/coverage.base 62 | lcov --capture --base-directory . --directory build/gfortran_*/ --output-file ${{ env.COV_DIR }}/coverage.capture 63 | lcov --add-tracefile ${{ env.COV_DIR }}/coverage.base --add-tracefile ${{ env.COV_DIR }}/coverage.capture --output-file ${{ env.COV_DIR }}/coverage.info 64 | env: 65 | COV_DIR: build/coverage 66 | 67 | - name: Upload coverage report 68 | uses: codecov/codecov-action@v2 69 | with: 70 | files: build/coverage/coverage.info 71 | 72 | - name: Build documentation 73 | run: ford ./fortran_function_parser.md 74 | 75 | - name: Deploy Documentation 76 | if: github.ref == 'refs/heads/master' 77 | uses: JamesIves/github-pages-deploy-action@v4.3.3 78 | with: 79 | branch: gh-pages # The branch the action should deploy to. 80 | folder: doc # The folder the action should deploy. 81 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Fortran Function Parser 2 | https://github.com/jacobwilliams/fortran_function_parser 3 | 4 | Copyright (c) 2017-2022, Jacob Williams 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, this 14 | list of conditions and the following disclaimer in the documentation and/or 15 | other materials provided with the distribution. 16 | 17 | * The names of its contributors may not be used to endorse or promote products 18 | derived from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 21 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 25 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 26 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 27 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 29 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | -------------------------------------------------------------------------------- 32 | Original FPARSER v1.1 License 33 | -------------------------------------------------------------------------------- 34 | 35 | Copyright (c) 2000-2008, Roland Schmehl. 36 | 37 | All rights reserved. 38 | 39 | * Redistribution and use in source and binary forms, with or without 40 | modification, are permitted provided that the following conditions are 41 | met: 42 | 43 | * Redistributions of source code must retain the above copyright notice, 44 | this list of conditions and the following disclaimer. 45 | 46 | * Redistributions in binary form must reproduce the above copyright 47 | notice, this list of conditions and the following disclaimer in the 48 | documentation and/or other materials provided with the distribution. 49 | 50 | * Neither the name of the copyright holder nor the names of its 51 | contributors may be used to endorse or promote products derived from 52 | this software without specific prior written permission. 53 | 54 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 55 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 56 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 57 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 58 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 59 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 60 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 61 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 62 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 63 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 64 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 65 | 66 | -------------------------------------------------------------------------------- 67 | -------------------------------------------------------------------------------- /src/error_module.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> author: Jacob Williams 3 | ! license: BSD 4 | ! 5 | ! A simple type for storing error messages. 6 | ! Used by the [[function_parser] module. 7 | ! 8 | !@note The error message is stored internally as an 9 | ! allocatable character string. So it can be 10 | ! as large as it needs to be. 11 | 12 | module error_module 13 | 14 | implicit none 15 | 16 | private 17 | 18 | type :: error 19 | !! A error message in the [[list_of_errors]]. 20 | private 21 | character(len=:),allocatable :: content !! the error message string 22 | end type error 23 | 24 | type,public :: list_of_errors 25 | !! A list of errors. 26 | !! 27 | !! This is implemented as a simple allocatable 28 | !! array of [[error]] types. 29 | private 30 | type(error),dimension(:),allocatable :: head !! the error list 31 | contains 32 | private 33 | procedure,public :: add => add_error_to_list 34 | procedure,public :: print => print_errors 35 | procedure,public :: has_errors => list_has_errors 36 | procedure,public :: destroy => destroy_list 37 | final :: list_finalizer 38 | end type list_of_errors 39 | 40 | contains 41 | !******************************************************************************* 42 | 43 | !******************************************************************************* 44 | !> 45 | ! Will be called automatically when the list goes out of scope. 46 | 47 | pure elemental subroutine list_finalizer(me) 48 | 49 | implicit none 50 | 51 | type(list_of_errors),intent(inout) :: me 52 | 53 | call me%destroy() 54 | 55 | end subroutine list_finalizer 56 | !******************************************************************************* 57 | 58 | !******************************************************************************* 59 | !> 60 | ! To manually destroy the list. 61 | ! 62 | ! Also note that there is a finalizer in the [[list_of_errors]], 63 | ! so if the caller doesn't call this routine, it will be destroyed 64 | ! when it goes out of scope, assuming the compiler is standard-conforming. 65 | 66 | pure elemental subroutine destroy_list(me) 67 | 68 | implicit none 69 | 70 | class(list_of_errors),intent(inout) :: me 71 | 72 | integer :: i !! counter 73 | 74 | if (allocated(me%head)) then 75 | do i = 1, size(me%head) 76 | if (allocated(me%head(i)%content)) & 77 | deallocate(me%head(i)%content) 78 | end do 79 | deallocate(me%head) 80 | end if 81 | 82 | end subroutine destroy_list 83 | !******************************************************************************* 84 | 85 | !******************************************************************************* 86 | !> 87 | ! Add an error message to the list. 88 | 89 | subroutine add_error_to_list(me,string) 90 | 91 | implicit none 92 | 93 | class(list_of_errors),intent(inout) :: me 94 | character(len=*),intent(in) :: string !! the error message to add. 95 | 96 | type(error),dimension(:),allocatable :: tmp !! for expanding the array 97 | integer :: n !! number of errors currently in the list 98 | 99 | if (.not. allocated(me%head)) then 100 | 101 | !first error in the list 102 | allocate(me%head(1)) 103 | me%head(1)%content = string 104 | 105 | else 106 | 107 | ! add to the list 108 | n = size(me%head) 109 | allocate(tmp(n+1)) 110 | tmp(1:n) = me%head 111 | tmp(n+1)%content = string 112 | call move_alloc(tmp,me%head) 113 | 114 | end if 115 | 116 | end subroutine add_error_to_list 117 | !******************************************************************************* 118 | 119 | !******************************************************************************* 120 | !> 121 | ! Returns true if the list contains any error messages. 122 | 123 | pure elemental function list_has_errors(me) 124 | 125 | implicit none 126 | 127 | class(list_of_errors),intent(in) :: me 128 | logical :: list_has_errors 129 | 130 | list_has_errors = allocated(me%head) 131 | 132 | end function list_has_errors 133 | !******************************************************************************* 134 | 135 | !******************************************************************************* 136 | !> 137 | ! Print all the error messages in the list. 138 | 139 | subroutine print_errors(me,iunit) 140 | 141 | implicit none 142 | 143 | class(list_of_errors),intent(in) :: me 144 | integer,intent(in) :: iunit !! unit number for printing 145 | !! (assumed to be open) 146 | 147 | integer :: i !! counter 148 | 149 | if (allocated(me%head)) then 150 | do i = 1, size(me%head) 151 | write(iunit,fmt='(A)') me%head(i)%content 152 | end do 153 | end if 154 | 155 | end subroutine print_errors 156 | !******************************************************************************* 157 | 158 | !******************************************************************************* 159 | end module error_module 160 | !******************************************************************************* 161 | -------------------------------------------------------------------------------- /media/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 21 | 23 | 26 | 30 | 34 | 35 | 41 | 44 | 51 | 52 | 55 | 62 | 63 | 69 | 75 | 81 | 87 | 97 | 98 | 121 | 123 | 124 | 126 | image/svg+xml 127 | 129 | 130 | 131 | 132 | 133 | 138 | 146 | 154 | 157 | Fortran 164 | Function 171 | Parser 178 | 179 | 180 | 181 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![fortran_function_parser](media/logo.png) 2 | ============ 3 | 4 | ### Status 5 | 6 | [![GitHub release](https://img.shields.io/github/release/jacobwilliams/fortran_function_parser.svg)](https://github.com/jacobwilliams/fortran_function_parser/releases/latest) 7 | [![Build Status](https://github.com/jacobwilliams/fortran_function_parser/actions/workflows/CI.yml/badge.svg)](https://github.com/jacobwilliams/fortran_function_parser/actions) 8 | [![codecov](https://codecov.io/gh/jacobwilliams/fortran_function_parser/branch/master/graph/badge.svg)](https://codecov.io/gh/jacobwilliams/fortran_function_parser) 9 | [![last-commit](https://img.shields.io/github/last-commit/jacobwilliams/fortran_function_parser)](https://github.com/jacobwilliams/fortran_function_parser/commits/master) 10 | 11 | ### Description 12 | 13 | This function parser module is intended for applications where a set of 14 | mathematical fortran-style expressions is specified at runtime and is 15 | then evaluated for a large number of variable values. This is done by 16 | compiling the set of function strings into byte code, which is 17 | interpreted efficiently for the various variable values. 18 | 19 | This code is a modernized version of [fparser](http://fparser.sourceforge.net) (v1.1), a Fortran 95 function parser (v1.1) by [Roland Schmehl](roland.schmehl@alumni.uni-karlsruhe.de). The function parser concept is based on a C++ class library written by Juha Nieminen available from [here](http://warp.povusers.org/FunctionParser/). The original code has been updated to Fortran 2008 by Jacob Williams. Development continues on [GitHub](https://github.com/jacobwilliams/fortran_function_parser). 20 | 21 | ### Building 22 | 23 | The library can be built with the [Fortran Package Manager](https://github.com/fortran-lang/fpm) using the provided `fpm.toml` file like so: 24 | 25 | ```bash 26 | fpm build --release 27 | ``` 28 | 29 | By default, the library is built with double precision (`real64`) real values. Explicitly specifying the real kind can be done using the following preprocessor flags: 30 | 31 | Preprocessor flag | Kind | Number of bytes 32 | ----------------- | ----- | --------------- 33 | `REAL32` | `real(kind=real32)` | 4 34 | `REAL64` | `real(kind=real64)` | 8 35 | `REAL128` | `real(kind=real128)` | 16 36 | 37 | For example, to build a single precision version of the library, use: 38 | 39 | ``` 40 | fpm build --profile release --flag "-DREAL32" 41 | ``` 42 | 43 | To use `fortran_function_parser` within your fpm project, add the following to your `fpm.toml` file: 44 | 45 | ```toml 46 | [dependencies] 47 | fortran_function_parser = { git="https://github.com/jacobwilliams/fortran_function_parser.git" } 48 | ``` 49 | 50 | Or, to use a specific version: 51 | 52 | ```toml 53 | [dependencies] 54 | fortran_function_parser = { git="https://github.com/jacobwilliams/fortran_function_parser.git", tag = "1.1.0" } 55 | ``` 56 | 57 | ### Documentation 58 | 59 | The latest API documentation can be found [here](https://jacobwilliams.github.io/fortran_function_parser/). This was generated from the source code using [FORD](https://github.com/Fortran-FOSS-Programmers/ford). 60 | 61 | ### Basic usage 62 | 63 | #### Module Import 64 | 65 | In all program units where you want to use the function parser 66 | you must import the module by: 67 | 68 | ```fortran 69 | use function_parser 70 | ``` 71 | 72 | This command imports only 3 public types: `fparser`, `fparser_array`, and 73 | `list_of_errors`, which are explained in the following. The remainder of the 74 | module is hidden to the calling program. 75 | 76 | #### Function parsing 77 | 78 | A single function string `funcstr` can be parsed (checked and compiled) into 79 | bytecode by calling the `fparser` class method subroutine `parse`: 80 | 81 | ```fortran 82 | call me%parse(funcstr, var, case_sensitive) 83 | ``` 84 | 85 | The variable names as they appear in the string `funcstr` have to be passed 86 | in the one-dimensional string array `var` (zero size of `var` is acceptable). 87 | The number of variables is implicitly passed by the dimension of this array. 88 | For some notes on the syntax of the function string see below. 89 | 90 | To parse an array of function strings, you can use the `fparser_array` class 91 | method `parse` in a similar manner. 92 | 93 | #### Function evaluation 94 | 95 | The function value is evaluated for a specific set of variable values 96 | by calling the `fparser` class method subroutine `evaluate`: 97 | 98 | ```fortran 99 | call me%evaluate(val, res) 100 | ``` 101 | 102 | The variable values are passed in the one-dimensional array `val` which must 103 | have the same dimension as array `var`. 104 | 105 | To evaluate an array of function strings, you can use the `fparser_array` class 106 | method `evaluate` in a similar manner. 107 | 108 | #### Cleanup 109 | 110 | To free the memory and destroy a variable of type `fparser` or `fparser_array`, 111 | use the `destroy` method: 112 | 113 | ```fortran 114 | call me%destroy() 115 | ``` 116 | 117 | ### Error handling 118 | 119 | Errors can be reported by both the `parse` and `evaluate` 120 | class methods. To check for errors, use the `error` method, and to print them use the `print_errors` method: 121 | 122 | ```fortran 123 | if (me%error()) then 124 | me%print_errors(output_unit) 125 | end if 126 | ``` 127 | 128 | An error in the function parsing step leads to a detailed error message 129 | (type and position of error). An error during function evaluation returns a function value of 0.0. 130 | 131 | ### Function string syntax 132 | 133 | Although they have to be passed as array elements of the same declared 134 | length (Fortran restriction), the variable names can be of arbitrary 135 | actual length for the parser. By default, parsing for variables is case insensitive, 136 | but case sensitive evaluation is also an option. 137 | 138 | The syntax of the function string is similar to the Fortran convention. 139 | Mathematical Operators recognized are `+,` `-,` `*,` `/,` `**` or alternatively `^,` 140 | whereas symbols for brackets must be `()`. 141 | 142 | The function parser recognizes the (single argument) Fortran intrinsic 143 | functions: 144 | * [`abs`](https://fortran-lang.org/learn/intrinsics/ABS), [`acos`](https://fortran-lang.org/learn/intrinsics/ACOS), [`asin`](https://fortran-lang.org/learn/intrinsics/ASIN), [`atan`](https://fortran-lang.org/learn/intrinsics/ATAN), [`atan2`](https://fortran-lang.org/learn/intrinsics/ATAN2), [`ceiling`](https://fortran-lang.org/learn/intrinsics/CEILING), [`cos`](https://fortran-lang.org/learn/intrinsics/COS), [`cosh`](https://fortran-lang.org/learn/intrinsics/COSH), [`exp`](https://fortran-lang.org/learn/intrinsics/EXP), [`floor`](https://fortran-lang.org/learn/intrinsics/FLOOR), [`gamma`](https://fortran-lang.org/learn/intrinsics/GAMMA), [`hypot`](https://fortran-lang.org/learn/intrinsics/HYPOT), [`log`](https://fortran-lang.org/learn/intrinsics/LOG), [`log10`](https://fortran-lang.org/learn/intrinsics/LOG10), [`max`](https://fortran-lang.org/learn/intrinsics/MAX), [`min`](https://fortran-lang.org/learn/intrinsics/MIN), [`mod`](https://fortran-lang.org/learn/intrinsics/MOD), [`modulo`](https://fortran-lang.org/learn/intrinsics/MODULO), [`sign`](https://fortran-lang.org/learn/intrinsics/SIGN), [`sin`](https://fortran-lang.org/learn/intrinsics/SIN), [`sinh`](https://fortran-lang.org/learn/intrinsics/SINH), [`sqrt`](https://fortran-lang.org/learn/intrinsics/SQRT), [`tan`](https://fortran-lang.org/learn/intrinsics/TAN), [`tanh`](https://fortran-lang.org/learn/intrinsics/TANH) 145 | 146 | In addition, the following zero-argument function: 147 | * `pi` -- Returns the value of $\pi$ 148 | 149 | And the three-argument function: 150 | * `if` -- Logical comparision function. The syntax is: `if(expression, value if true, value if false)`, where 0.0 is false, and any other real value is true. 151 | 152 | Parsing for functions is always case INsensitive. 153 | 154 | Operations are evaluated in the correct order: 155 | 156 | * `() ` expressions in brackets first 157 | * `-A ` unary minus (or plus) 158 | * `A**B A^B` exponentiation (`A` raised to the power `B`) 159 | * `A*B A/B` multiplication and division 160 | * `A+B A-B` addition and subtraction 161 | 162 | The function string can contain integer or real constants. To be recognized 163 | as explicit constants these must conform to the format 164 | 165 | `[+|-][nnn][.nnn][e|E|d|D[+|-]nnn]` 166 | 167 | where `nnn` means any number of digits. The mantissa must contain at least 168 | one digit before or following an optional decimal point. Valid exponent 169 | identifiers are 'e', 'E', 'd' or 'D'. If they appear they must be followed 170 | by a valid exponent. 171 | 172 | ### Other codes 173 | 174 | There are various other expression parsers out there written in Fortran: 175 | 176 | ```mermaid 177 | flowchart TB 178 | fparser[fparser] 179 | fparser-->FortranParser[FortranParser] 180 | fparser-->fortran_function_parser[fortran_function_parser] 181 | fortran_parser-->fortran_script[fortran_script] 182 | ffp[Fortran Function Parser] 183 | feq-parse[feq-parse] 184 | fortran_parser[fortran_parser] 185 | M_calculator[M_calculator] 186 | M_calculator-->compute[compute] 187 | 188 | ``` 189 | 190 | * [fparser](http://fparser.sourceforge.net) -- Original Fortran 95 function parser by Roland Schmehl. 191 | * [FortranParser](https://github.com/jacopo-chevallard/FortranParser) -- Another refactoring of the original `fparser` code by Jacopo Chevallard. 192 | * [Fortran Function Parser](http://www.labfit.net/functionparser.htm) -- An entirely different code by Wilton and Ivomar, 10/01/2007 (GitHub mirror [here](https://github.com/jacobwilliams/ffp)). 193 | * [feq-parse](https://github.com/FluidNumerics/feq-parse) -- Fortran Equation Parser from FluidNumerics. 194 | * [fortran_parser](https://github.com/sdm900/fortran_parser) -- Fortran Equation Parser from Stuart Midgley. 195 | * [M_calculator](https://github.com/urbanjost/M_calculator) -- Parse Fortran-like double precision scalar expressions from urbanjost 196 | 197 | ### See also 198 | 199 | * [Application of Modern Fortran to Spacecraft Trajectory Design and Optimization](https://ntrs.nasa.gov/api/citations/20180000413/downloads/20180000413.pdf) (AIAA 2018-1451) describes a method of constructing a Fortran expression parser using binary syntax trees. 200 | * [Dynamic Eval for Fortran](https://github.com/j3-fortran/fortran_proposals/issues/126) Suggestion to add dynamic expression evaluation to the Fortran language (don't hold your breath). -------------------------------------------------------------------------------- /test/tests.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> license: BSD 3 | ! 4 | ! Test cases for the function parser module. 5 | 6 | program tests 7 | 8 | use function_parser, wp => fparser_rk 9 | use iso_fortran_env, only: output_unit 10 | 11 | implicit none 12 | 13 | call fptest() 14 | call fptest2() 15 | call fptest3() 16 | call fptest4() 17 | call fptest5() 18 | call fptest6() 19 | call fptest7() 20 | call error_tests() 21 | call fptest8() 22 | 23 | contains 24 | !******************************************************************************* 25 | 26 | !******************************************************************************* 27 | subroutine fptest() 28 | 29 | character(len=*),parameter :: func = '-x' 30 | integer,parameter :: nvar = 1 !! number of variables 31 | character(len=*),dimension(nvar),parameter :: var = [ 'x' ] 32 | real(wp),dimension(nvar),parameter :: val = [ 2.0_wp ] 33 | 34 | type(fparser) :: parser 35 | real(wp) :: res 36 | real(wp) :: x 37 | 38 | write(*,*) '' 39 | write(*,*) ' Test 1' 40 | write(*,*) '' 41 | 42 | call parser%parse(func, var, .false.) ! parse and bytecompile function string 43 | if (parser%error()) then 44 | call parser%print_errors(output_unit) 45 | error stop 46 | end if 47 | 48 | call parser%evaluate(val,res) ! interprete bytecode representation of function 49 | if (parser%error()) then 50 | call parser%print_errors(output_unit) 51 | else 52 | x = val(1) 53 | call compare('-x', -x, res) 54 | end if 55 | 56 | end subroutine fptest 57 | !******************************************************************************* 58 | 59 | !******************************************************************************* 60 | subroutine fptest2() 61 | 62 | implicit none 63 | 64 | integer, parameter :: nfunc = 3 65 | character (len=*), dimension(nfunc), parameter :: func = [ 'a0*b0 ', & 66 | 'a1/b1 ', & 67 | 'a3**b3' ] 68 | integer, parameter :: nvar = 6 69 | character (len=*), dimension(nvar), parameter :: var = [ 'a0', & 70 | 'b0', & 71 | 'a1', & 72 | 'b1', & 73 | 'a3', & 74 | 'b3' ] 75 | real(wp),dimension(nvar),parameter :: val = [ 1.0_wp, 2.0_wp, 3.0_wp, & 76 | 1.0_wp, 5.0_wp, 6.0_wp ] 77 | 78 | type(fparser_array) :: parser 79 | real(wp),dimension(nfunc) :: res 80 | real(wp) :: a0,b0,a1,b1,a3,b3 81 | 82 | write(*,*) '' 83 | write(*,*) ' Test 2' 84 | write(*,*) '' 85 | 86 | call parser%parse(func, var, .false.) ! parse and bytecompile function string 87 | if (parser%error()) then 88 | call parser%print_errors(output_unit) 89 | error stop 90 | end if 91 | 92 | call parser%evaluate(val,res) ! interprete bytecode representation of function 93 | if (parser%error()) then 94 | call parser%print_errors(output_unit) 95 | else 96 | a0 = val(1) 97 | b0 = val(2) 98 | a1 = val(3) 99 | b1 = val(4) 100 | a3 = val(5) 101 | b3 = val(6) 102 | call compare('a0*b0', a0*b0, res(1)) 103 | call compare('a1/b1', a1/b1, res(2)) 104 | call compare('a3**b3', a3**b3, res(3)) 105 | end if 106 | 107 | end subroutine fptest2 108 | !******************************************************************************* 109 | 110 | !******************************************************************************* 111 | subroutine fptest3() 112 | 113 | implicit none 114 | 115 | integer, parameter :: nfunc = 3 116 | character (len=*), dimension(nfunc), parameter :: func = [ 'vel*cos(beta) ', & 117 | 'vel*sin(beta)*cos(alpha)', & 118 | 'vel*sin(beta)*sin(alpha)' ] 119 | integer, parameter :: nvar = 3 120 | character (len=*), dimension(nvar), parameter :: var = [ 'vel ', & 121 | 'alpha', & 122 | 'beta ' ] 123 | real(wp), dimension(nvar), parameter :: val = [ 10., 1.5, 2.0 ] 124 | 125 | type(fparser_array) :: parser 126 | real(wp),dimension(nfunc) :: res 127 | real(wp) :: vel,alpha,beta 128 | 129 | write(*,*) '' 130 | write(*,*) ' Test 3' 131 | write(*,*) '' 132 | 133 | call parser%parse(func, var, .false.) ! parse and bytecompile function string 134 | if (parser%error()) then 135 | call parser%print_errors(output_unit) 136 | error stop 137 | end if 138 | 139 | call parser%evaluate(val,res) ! interprete bytecode representation of function 140 | if (parser%error()) then 141 | call parser%print_errors(output_unit) 142 | else 143 | vel = val(1) 144 | alpha = val(2) 145 | beta = val(3) 146 | call compare('vel*cos(beta)', vel*cos(beta), res(1)) 147 | call compare('vel*sin(beta)*cos(alpha)', vel*sin(beta)*cos(alpha), res(2)) 148 | call compare('vel*sin(beta)*sin(alpha)', vel*sin(beta)*sin(alpha), res(3)) 149 | end if 150 | 151 | end subroutine fptest3 152 | !******************************************************************************* 153 | 154 | !******************************************************************************* 155 | !> 156 | ! Assesses how fast the interpreter is compared against a direct evaluation. 157 | 158 | subroutine fptest4() 159 | 160 | implicit none 161 | 162 | integer, parameter :: neval = 1000000 163 | integer, parameter :: nfunc = 3 164 | character (len=*), dimension(nfunc), parameter :: func = [ 'vel*cos(beta) ', & 165 | 'vel*sin(beta)*cos(alpha)', & 166 | 'vel*sin(beta)*sin(alpha)' ] 167 | integer, parameter :: nvar = 3 168 | character (len=*), dimension(nvar), parameter :: var = [ 'vel ', & 169 | 'alpha', & 170 | 'beta ' ] 171 | real(wp), dimension(nvar), parameter :: val = [ 10., 1.5, 2.0 ] 172 | 173 | type(fparser_array) :: parser 174 | real(wp),dimension(nfunc) :: res 175 | integer :: n 176 | real :: rt1,rt2,rt3 177 | real(wp) :: vel,alpha,beta 178 | 179 | write(*,*) '' 180 | write(*,*) ' Test 4' 181 | write(*,*) '' 182 | 183 | call parser%parse(func, var, .false.) ! parse and bytecompile function string 184 | if (parser%error()) then 185 | call parser%print_errors(output_unit) 186 | error stop 187 | end if 188 | 189 | vel = val(1) 190 | alpha = val(2) 191 | beta = val(3) 192 | call cpu_time (rt1) ! ----- 193 | do n=1,neval 194 | call parser%evaluate(val,res) ! interprete bytecode representation of function 195 | end do 196 | call cpu_time (rt2) ! ----- 197 | if (parser%error()) then 198 | call parser%print_errors(output_unit) 199 | error stop 200 | end if 201 | 202 | call cpu_time (rt2) ! ----- 203 | do n=1,neval 204 | res(1) = vel*cos(beta) 205 | res(2) = vel*sin(beta)*cos(alpha) 206 | res(3) = vel*sin(beta)*sin(alpha) 207 | end do 208 | call cpu_time (rt3) ! ----- 209 | 210 | write(*,*)'function evaluation:' 211 | write(*,*)' * bytecode interpreter cpu time = ',rt2-rt1 212 | write(*,*)' * machine code cpu time = ',rt3-rt2,' = ',(rt3-rt2)/(rt2-rt1)*100.0_wp,'%' 213 | 214 | end subroutine fptest4 215 | !******************************************************************************* 216 | 217 | !******************************************************************************* 218 | !> 219 | ! An example with no variables. 220 | 221 | subroutine fptest5() 222 | 223 | implicit none 224 | 225 | character(len=*),parameter :: func = '1.0e0 + 5.e1' 226 | character(len=*),dimension(1),parameter :: var = 'a' !! not really used here 227 | real(wp),dimension(1),parameter :: val = [0.0_wp] !! not really used here 228 | 229 | type(fparser) :: parser 230 | real(wp) :: res 231 | 232 | write(*,*) '' 233 | write(*,*) ' Test 5' 234 | write(*,*) '' 235 | 236 | call parser%parse(func, var, .false.) ! parse and bytecompile function string 237 | if (parser%error()) then 238 | call parser%print_errors(output_unit) 239 | error stop 240 | end if 241 | 242 | call parser%evaluate(val,res) ! interprete bytecode representation of function 243 | if (parser%error()) then 244 | call parser%print_errors(output_unit) 245 | error stop 246 | else 247 | call compare('1.0e0 + 5.e1', real(1.0e0 + 5.e1, wp), res) 248 | end if 249 | 250 | end subroutine fptest5 251 | !******************************************************************************* 252 | 253 | !******************************************************************************* 254 | !> 255 | ! 256 | !### Notes 257 | ! * This one has cases where a variable has the same name as a built-in function. 258 | ! So, for some expressions we want the function, and others we want the variable. 259 | 260 | subroutine fptest6() 261 | 262 | implicit none 263 | 264 | integer, parameter :: nfunc = 30 265 | character (len=*), dimension(nfunc), parameter :: func = [ '-1.0*x ', & 266 | '-sqrt(x) ', & 267 | 'a*COS(b*x)+5 ', & 268 | 'a*COS(b*x)+5.0 ', & 269 | 'exp(x)-abs(x)+log(1.0)+log10(1.0) ', & 270 | 'sinh(x) ', & 271 | 'cosh(x) ', & 272 | 'tanh(x) ', & 273 | 'tan(x) ', & 274 | 'asin(y) ', & 275 | 'acos(y) ', & 276 | 'atan(y) ', & 277 | '-x**2 ', & 278 | '-x^2 ', & 279 | 'sin(x) ', & 280 | 'sin*2 ', & 281 | '2*(sin)*sin+1-sin(x) ', & 282 | 'ceiling(1.1) + ceiling(1.1) ', & 283 | 'floor(1.1) + floor(1.1) ', & 284 | 'gamma(2.0) ', & 285 | 'hypot(1.0, 2.0) ', & 286 | 'max(1.0, 2.0) ', & 287 | 'min(1.0, 2.0) ', & 288 | 'atan2(180.0, 23.0) ', & 289 | 'atan2(1.0, -2.0) ', & 290 | 'atan2(180.0, -23.0)+atan2(180.0, 23.0) ', & 291 | 'mod(180.0, 23.0) ', & 292 | 'modulo(180.0, 23.0) ', & 293 | 'mod(-180.0, 23.0)+modulo(180.0, -23.0) ', & 294 | 'sign(1.0, -2.0) ' ] 295 | 296 | integer, parameter :: nvar = 5 297 | character (len=*), dimension(nvar), parameter :: var = [ 'x ', & 298 | 'a ', & 299 | 'b ', & 300 | 'y ', & 301 | 'sin' ] !! sin is a built-in function 302 | real(wp), dimension(nvar), parameter :: val = [ 2.0_wp, 3.0_wp, 4.0_wp, 0.1_wp, 1.0_wp ] 303 | 304 | type(fparser_array) :: parser 305 | real(wp),dimension(nfunc) :: res 306 | real(wp) :: x,a,b,y,s 307 | 308 | write(*,*) '' 309 | write(*,*) ' Test 6' 310 | write(*,*) '' 311 | 312 | call parser%parse(func, var, .false.) ! parse and bytecompile function string 313 | if (parser%error()) then 314 | call parser%print_errors(output_unit) 315 | error stop 316 | end if 317 | 318 | call parser%evaluate(val,res) ! interprete bytecode representation of function 319 | if (parser%error()) then 320 | call parser%print_errors(output_unit) 321 | error stop 322 | else 323 | x = val(1) 324 | a = val(2) 325 | b = val(3) 326 | y = val(4) 327 | s = val(5) 328 | call compare(func(1), -1.0_wp*x, res(1)) 329 | call compare(func(2), -sqrt(x), res(2)) 330 | call compare(func(3), a*cos(b*x)+5, res(3)) 331 | call compare(func(4), a*cos(b*x)+5.0, res(4)) 332 | call compare(func(5), exp(x)-abs(x)+log(1.0)+log10(1.0), res(5)) 333 | call compare(func(6), sinh(x), res(6)) 334 | call compare(func(7), cosh(x), res(7)) 335 | call compare(func(8), tanh(x), res(8)) 336 | call compare(func(9), tan(x), res(9)) 337 | call compare(func(10), asin(y), res(10)) 338 | call compare(func(11), acos(y), res(11)) 339 | call compare(func(12), atan(y), res(12)) 340 | call compare(func(13), -x**2, res(13)) 341 | call compare(func(14), -x**2, res(14)) 342 | call compare(func(15), sin(x), res(15)) 343 | call compare(func(16), 2.0_wp, res(16)) 344 | call compare(func(17), 2*(s)*s+1-sin(x), res(17)) 345 | call compare(func(18), real(ceiling(1.1_wp) + ceiling(1.1_wp), wp) , res(18)) 346 | call compare(func(19), real(floor(1.1_wp) + floor(1.1_wp), wp) , res(19)) 347 | call compare(func(20), gamma(2.0_wp) , res(20)) 348 | call compare(func(21), hypot(1.0_wp, 2.0_wp) , res(21)) 349 | call compare(func(22), max(1.0_wp, 2.0_wp) , res(22)) 350 | call compare(func(23), min(1.0_wp, 2.0_wp) , res(23)) 351 | call compare(func(24), atan2(180.0_wp, 23.0_wp) , res(24)) 352 | call compare(func(25), atan2(1.0_wp, -2.0_wp) , res(25)) 353 | call compare(func(26), atan2(180.0_wp, -23.0_wp)+atan2(180.0_wp, 23.0_wp) , res(26)) 354 | call compare(func(27), mod(180.0_wp, 23.0_wp) , res(27)) 355 | call compare(func(28), modulo(180.0_wp, 23.0_wp) , res(28)) 356 | call compare(func(29), mod(-180.0_wp, 23.0_wp)+modulo(180.0_wp, -23.0_wp) , res(29)) 357 | call compare(func(30), sign(1.0_wp, -2.0_wp) , res(30)) 358 | 359 | end if 360 | 361 | end subroutine fptest6 362 | !******************************************************************************* 363 | 364 | !******************************************************************************* 365 | !> 366 | ! Functions of multiple arguments. 367 | 368 | subroutine fptest7() 369 | 370 | implicit none 371 | 372 | integer, parameter :: nfunc = 18 373 | character (len=*), dimension(nfunc), parameter :: func = [ ' atan(2.0) ', & 374 | ' atan(2.0, 1.7) ', & 375 | ' atan(x) ', & 376 | ' atan(x, x) ', & 377 | ' atan(x, 3.5) ', & 378 | ' atan(x, cos(4.5 + atan(3.0 + atan(7.0, x))))*atan(4.6)', & 379 | ' atan(y, x) ', & 380 | ' atan(y, x*z) ', & 381 | ' atan(abs(y)*atan(x + y, z)) ', & 382 | '-atan(y - z, x + 3.0) ', & 383 | '-atan(x*y*z)*atan(y, x*y*z) ', & 384 | '-atan(y) ', & 385 | ' atan2(4.5, y) ', & 386 | ' -atan2(x, z) ', & 387 | ' 5+cos(pi()) ', & 388 | '-pi() ', & 389 | ' if(x,y,z) - x - y - z + 1 ', & 390 | '-if(pi()*0, y, z) ' ] 391 | integer, parameter :: nvar = 3 392 | character (len=*), dimension(nvar), parameter :: var = [ 'x', & 393 | 'y', & 394 | 'z' ] 395 | 396 | real(wp), dimension(nvar), parameter :: val = [ 2.0_wp, -3.0_wp, 4.7_wp ] 397 | 398 | type(fparser_array) :: parser 399 | real(wp),dimension(nfunc) :: res 400 | real(wp) :: x,y,z 401 | 402 | write(*,*) '' 403 | write(*,*) ' Test 7' 404 | write(*,*) '' 405 | 406 | call parser%parse(func, var, .false.) ! parse and bytecompile function string 407 | if (parser%error()) then 408 | call parser%print_errors(output_unit) 409 | error stop 410 | end if 411 | 412 | call parser%evaluate(val,res) ! interprete bytecode representation of function 413 | if (parser%error()) then 414 | call parser%print_errors(output_unit) 415 | error stop 416 | end if 417 | 418 | x = val(1) 419 | y = val(2) 420 | z = val(3) 421 | 422 | ! Use atan2(x,y) instead of atan(x,y); some Intel ifort compiler versions 423 | ! that technically support atan(x,y) have bugs that can occasionally cause 424 | ! internal compiler error segfaults. 425 | call compare(func(1), atan(2.0_wp), res(1) ) 426 | call compare(func(2), atan2(2.0_wp, 1.7_wp), res(2) ) 427 | call compare(func(3), atan(x), res(3) ) 428 | call compare(func(4), atan2(x, x), res(4) ) 429 | call compare(func(5), atan2(x, 3.5_wp), res(5) ) 430 | call compare(func(6), atan2(x, cos(4.5_wp + atan(3.0_wp + atan2(7.0_wp, x))))*atan(4.6_wp), res(6) ) 431 | call compare(func(7), atan2(y, x), res(7) ) 432 | call compare(func(8), atan2(y, x*z) , res(8) ) 433 | call compare(func(9), atan(abs(y)*atan2(x + y, z)), res(9) ) 434 | call compare(func(10), -atan2(y - z, x + 3.0_wp), res(10)) 435 | call compare(func(11), -atan(x*y*z)*atan2(y, x*y*z), res(11)) 436 | call compare(func(12), -atan(y), res(12)) 437 | call compare(func(13), atan2(4.5_wp, y) , res(13)) 438 | call compare(func(14), -atan2(x,z), res(14)) 439 | call compare(func(15), 5.0_wp + cos(acos(-1.0_wp)), res(15)) 440 | call compare(func(16), -acos(-1.0_wp), res(16)) 441 | call compare(func(17), y - x - y - z + 1, res(17)) 442 | call compare(func(18), -z, res(18)) 443 | 444 | end subroutine fptest7 445 | !******************************************************************************* 446 | 447 | 448 | !******************************************************************************* 449 | !> 450 | ! Testing order of operations 451 | 452 | subroutine fptest8() 453 | 454 | implicit none 455 | 456 | integer, parameter :: nfunc = 6 457 | character (len=*), dimension(nfunc), parameter :: func = [ 'x+y*x/x ', & 458 | 'x+y/x*x ', & 459 | '(x*y/x)**2+1 ', & 460 | '(x*y/x)**2*2**2+55 ', & 461 | '1/2+4*1+4*6/2/3*5/6', & 462 | '1/2+4*1-4*6*2*3/5*6' ] 463 | integer, parameter :: nvar = 3 464 | character (len=*), dimension(nvar), parameter :: var = [ 'x ', & 465 | 'y ', & 466 | 'z ' ] 467 | 468 | real(wp), dimension(nvar), parameter :: val = [ 2.0_wp, -3.0_wp, 4.7_wp ] 469 | 470 | type(fparser_array) :: parser 471 | real(wp),dimension(nfunc) :: res 472 | real(wp) :: x,y,z 473 | 474 | write(*,*) '' 475 | write(*,*) ' Test 8' 476 | write(*,*) '' 477 | 478 | call parser%parse(func, var, .false.) ! parse and bytecompile function string 479 | if (parser%error()) then 480 | call parser%print_errors(output_unit) 481 | error stop 482 | end if 483 | 484 | call parser%evaluate(val,res) ! interprete bytecode representation of function 485 | if (parser%error()) then 486 | call parser%print_errors(output_unit) 487 | error stop 488 | end if 489 | 490 | x = val(1) 491 | y = val(2) 492 | z = val(3) 493 | 494 | call compare(func(1), x+y*x/x , res(1) ) 495 | call compare(func(2), x+y/x*x , res(2) ) 496 | call compare(func(3), (x*y/x)**2+1.0_wp , res(3) ) 497 | call compare(func(4), (x*y/x)**2*2.0_wp**2+55.0_wp , res(4) ) 498 | call compare(func(5), 1.0_wp/2.0_wp+4.0_wp*1.0_wp+4*6.0_wp/2.0_wp/3.0_wp*5.0_wp/6.0_wp , res(5) ) 499 | call compare(func(6), 1.0_wp/2.0_wp+4.0_wp*1.0_wp-4.0_wp*6.0_wp*2.0_wp*3.0_wp/5.0_wp*6.0_wp , res(6) ) 500 | 501 | end subroutine fptest8 502 | !******************************************************************************* 503 | 504 | !******************************************************************************* 505 | !> 506 | ! Test some of the error cases. 507 | 508 | subroutine error_tests() 509 | 510 | implicit none 511 | 512 | integer, parameter :: nvar = 3 513 | character (len=*), dimension(nvar), parameter :: var = [ 'x', & 514 | 'a', & 515 | 'b' ] 516 | real(wp), dimension(nvar), parameter :: val = [ 2.0_wp, 3.0_wp, 4.0_wp ] 517 | type(fparser_array) :: parser 518 | 519 | write(*,*) '' 520 | write(*,*) ' Test 7 - Test error conditions' 521 | write(*,*) '' 522 | 523 | call parse_error(parser,'st(-x)',var,val) 524 | call parse_error(parser,'x * 452d3234.2323',var,val) 525 | call parse_error(parser,'x * (123',var,val) 526 | call parse_error(parser,'x +-* y',var,val) 527 | call parse_error(parser,'x + sin',var,val) 528 | call parse_error(parser,'-(1) + (+x) + ()',var,val) 529 | call parse_error(parser,'x +',var,val) 530 | call parse_error(parser,'cos()',var,val) 531 | call parse_error(parser,'log(a, b)',var,val) 532 | call parse_error(parser,'atan2(x)',var,val) 533 | call parse_error(parser,'atan(, 3)',var,val) 534 | call parse_error(parser,'abs(x, a, b, 3)',var,val) 535 | call parse_error(parser,'(((x))',var,val) 536 | call parse_error(parser,')*sin(b)',var,val) 537 | call parse_error(parser,'sin',var,val) 538 | 539 | call eval_error(parser,'sqrt(-x)',var,val) 540 | call eval_error(parser,'acos(10.0)',var,val) 541 | call eval_error(parser,'asin(10.0)',var,val) 542 | call eval_error(parser,'log(-x)',var,val) 543 | call eval_error(parser,'log10(-x)',var,val) 544 | call eval_error(parser,'1/0',var,val) 545 | 546 | end subroutine error_tests 547 | !******************************************************************************* 548 | 549 | subroutine parse_error(parser,str,var,val) 550 | type(fparser_array),intent(inout) :: parser 551 | character(len=*),intent(in) :: str !! expression with a parsing error 552 | character(len=*),dimension(:),intent(in) :: var 553 | real(wp),dimension(:),intent(in) :: val 554 | call parser%parse([str], var) ! parse and bytecompile function string 555 | if (parser%error()) then 556 | call parser%print_errors(output_unit) 557 | write(*,*) 'PASSED : parsing error' 558 | else 559 | error stop 'FAILED : there should have been a parsing error' 560 | end if 561 | call parser%clear_errors() 562 | call parser%destroy() 563 | end subroutine parse_error 564 | 565 | subroutine eval_error(parser,str,var,val) 566 | type(fparser_array),intent(inout) :: parser 567 | character(len=*),intent(in) :: str !! expression with a parsing error 568 | real(wp),dimension(1) :: res 569 | character(len=*),dimension(:),intent(in) :: var 570 | real(wp),dimension(:),intent(in) :: val 571 | call parser%parse([str], var, .True.) ! parse and bytecompile function string [case sensitive] 572 | if (parser%error()) then 573 | call parser%print_errors(output_unit) 574 | error stop 575 | end if 576 | call parser%evaluate(val,res) ! interprete bytecode representation of function 577 | if (parser%error()) then 578 | call parser%print_errors(output_unit) 579 | write(*,*) 'PASSED : evaluation errors detected' 580 | else 581 | error stop 'FAILED : there should have been evaluation errors' 582 | end if 583 | call parser%clear_errors() 584 | call parser%destroy() 585 | end subroutine eval_error 586 | 587 | !******************************************************************************* 588 | !> 589 | ! Compare the results from the parser with the actual expression 590 | 591 | subroutine compare(expression, truth, parser) 592 | 593 | implicit none 594 | 595 | character(len=*),intent(in) :: expression 596 | real(wp),intent(in) :: truth 597 | real(wp),intent(in) :: parser 598 | 599 | character(len=:), allocatable :: disp_expr 600 | 601 | disp_expr = trim(expression) 602 | if (len(disp_expr) > 30) disp_expr = disp_expr(1:26) // ' ...' 603 | 604 | ! if (truth == parser) then 605 | if (abs(truth-parser) <= 1000*epsilon(1.0_wp)) then 606 | write(*,'(1p,A30,A10,*(G0,1X))') disp_expr, ' PASSED: ', truth 607 | else 608 | write(*,'(1p,A30,A10,*(G0,1X))') disp_expr, ' FAILED: ', truth , parser, parser-truth 609 | error stop 'error evaluating expression' 610 | end if 611 | 612 | end subroutine compare 613 | !******************************************************************************* 614 | 615 | !******************************************************************************* 616 | end program tests 617 | !******************************************************************************* 618 | -------------------------------------------------------------------------------- /src/function_parser.F90: -------------------------------------------------------------------------------- 1 | !******************************************************************************* 2 | !> license: BSD 3 | ! 4 | ! Modern Fortran function parser. 5 | ! 6 | !### Original Description 7 | ! This function parser module is intended for applications where a set of mathematical 8 | ! fortran-style expressions is specified at runtime and is then evaluated for a large 9 | ! number of variable values. This is done by compiling the set of function strings 10 | ! into byte code, which is interpreted efficiently for the various variable values. 11 | ! 12 | !### History 13 | ! * Original code (Fortran 90 function parser v1.1) by: 14 | ! Roland Schmehl . 15 | ! The source code is available from http://fparser.sourceforge.net 16 | ! * The function parser concept is based on a C++ class library written by Juha 17 | ! Nieminen available from http://warp.povusers.org/FunctionParser/ 18 | ! * Expanded and updated to modern Fortran by Jacob Williams, 2017. 19 | ! 20 | !### License 21 | ! * Copyright (c) 2000-2008, Roland Schmehl. All rights reserved. 22 | ! * Copyright (c) 2017, Jacob Williams. All rights reserved. 23 | ! * This software is distributable under the BSD license. See the terms of the 24 | ! BSD license in the documentation provided with this software. 25 | ! 26 | !@note The default real kind (`wp`) can be 27 | ! changed using optional preprocessor flags. 28 | ! This library was built with real kind: 29 | #ifdef REAL32 30 | ! `real(kind=real32)` [4 bytes] 31 | #elif REAL64 32 | ! `real(kind=real64)` [8 bytes] 33 | #elif REAL128 34 | ! `real(kind=real128)` [16 bytes] 35 | #else 36 | ! `real(kind=real64)` [8 bytes] 37 | #endif 38 | 39 | module function_parser 40 | 41 | use error_module, only: list_of_errors 42 | use iso_fortran_env 43 | 44 | implicit none 45 | 46 | private 47 | 48 | #ifdef REAL32 49 | integer,parameter,public :: fparser_rk = real32 !! real kind used by this module [4 bytes] 50 | #elif REAL64 51 | integer,parameter,public :: fparser_rk = real64 !! real kind used by this module [8 bytes] 52 | #elif REAL128 53 | integer,parameter,public :: fparser_rk = real128 !! real kind used by this module [16 bytes] 54 | #else 55 | integer,parameter,public :: fparser_rk = real64 !! real kind used by this module [8 bytes] 56 | #endif 57 | 58 | integer,parameter :: wp = fparser_rk !! local copy of `fparser_rk` with a shorter name 59 | 60 | !parameters: 61 | real(wp), parameter :: zero = 0.0_wp 62 | real(wp), parameter :: one = 1.0_wp 63 | real(wp), parameter :: pi = acos(-one) 64 | 65 | ! Note: these should be continuous, unique integers: 66 | ! [they must have the values that correspond to the array indices below] 67 | integer, parameter :: cImmed = 1 68 | integer, parameter :: cNeg = 2 69 | integer, parameter :: cAdd = 3, & ! Operators 70 | cSub = 4, & 71 | cMul = 5, & 72 | cDiv = 6, & 73 | cPow = 7 74 | integer, parameter :: cAbs = 8, & ! Functions 75 | cExp = 9, & 76 | cLog10 = 10, & 77 | cLog = 11, & 78 | cSqrt = 12, & 79 | cSinh = 13, & 80 | cCosh = 14, & 81 | cTanh = 15, & 82 | cSin = 16, & 83 | cCos = 17, & 84 | cTan = 18, & 85 | cAsin = 19, & 86 | cAcos = 20, & 87 | cAtan2 = 21, & ! atan2 must precede atan to prevent aliasing. 88 | cAtan = 22, & 89 | cPi = 23, & ! Pi (function with zero arguments) 90 | cCeil = 24, & 91 | cFloor = 25, & 92 | cGamma = 26, & 93 | cHypot = 27, & 94 | cMax = 28, & 95 | cMin = 29, & 96 | cModulo = 30, & 97 | cMod = 31, & 98 | cSign = 32, & 99 | cIf = 33 ! if (three arguments) 100 | integer, parameter :: VarBegin = 34 101 | 102 | character(len=1), dimension(cAdd:cPow), parameter :: operators = [ '+', & ! plus 103 | '-', & ! minus 104 | '*', & ! multiply 105 | '/', & ! divide 106 | '^' ] ! power 107 | 108 | character(len=7), dimension(cAbs:cIf), parameter :: functions = [ 'abs ', & 109 | 'exp ', & 110 | 'log10 ', & 111 | 'log ', & 112 | 'sqrt ', & 113 | 'sinh ', & 114 | 'cosh ', & 115 | 'tanh ', & 116 | 'sin ', & 117 | 'cos ', & 118 | 'tan ', & 119 | 'asin ', & 120 | 'acos ', & 121 | 'atan2 ', & 122 | 'atan ', & 123 | 'pi ', & 124 | 'ceiling', & 125 | 'floor ', & 126 | 'gamma ', & 127 | 'hypot ', & 128 | 'max ', & 129 | 'min ', & 130 | 'modulo ', & 131 | 'mod ', & 132 | 'sign ', & 133 | 'if ' ] 134 | 135 | ! Specify the number of required arguments each `functions` element must have. 136 | integer, dimension(cAbs:cIf), parameter :: required_args = [ 1, & ! abs 137 | 1, & ! exp 138 | 1, & ! log10 139 | 1, & ! log 140 | 1, & ! sqrt 141 | 1, & ! sinh 142 | 1, & ! cosh 143 | 1, & ! tanh 144 | 1, & ! sin 145 | 1, & ! cos 146 | 1, & ! tan 147 | 1, & ! asin 148 | 1, & ! acos 149 | 2, & ! atan2 150 | 1, & ! atan 151 | 0, & ! pi 152 | 1, & ! Ceiling 153 | 1, & ! Floor 154 | 1, & ! Gamma 155 | 2, & ! Hypot 156 | 2, & ! Max 157 | 2, & ! Min 158 | 2, & ! Modulo 159 | 2, & ! Mod 160 | 2, & ! Sign 161 | 3 ] ! if 162 | 163 | ! Specify the number of optional arguments each `functions` element might have. 164 | integer, dimension(cAbs:cIf), parameter :: optional_args = [ 0, & ! abs 165 | 0, & ! exp 166 | 0, & ! log10 167 | 0, & ! log 168 | 0, & ! sqrt 169 | 0, & ! sinh 170 | 0, & ! cosh 171 | 0, & ! tanh 172 | 0, & ! sin 173 | 0, & ! cos 174 | 0, & ! tan 175 | 0, & ! asin 176 | 0, & ! acos 177 | 0, & ! atan2 178 | 1, & ! atan 179 | 0, & ! pi 180 | 0, & ! Ceiling 181 | 0, & ! Floor 182 | 0, & ! Gamma 183 | 0, & ! Hypot 184 | 0, & ! Max 185 | 0, & ! Min 186 | 0, & ! Modulo 187 | 0, & ! Mod 188 | 0, & ! Sign 189 | 0 ] ! if 190 | 191 | ! The maximum number of arguments any `functions` element might have. 192 | integer, parameter :: max_func_args = maxval(required_args + optional_args) 193 | 194 | !the list of error messages: 195 | integer,parameter :: error_div_by_zero = 1 196 | integer,parameter :: error_sqrt_arg_neg = 2 197 | integer,parameter :: error_log_arg_neg = 3 198 | integer,parameter :: error_asin_arg_illegal = 4 199 | integer,parameter :: error_acos_arg_illegal = 5 200 | integer,parameter :: error_invalid_operation = 6 201 | character(len=25),dimension(6),parameter :: error_messages = & 202 | [ 'Division by zero ', & ! 1 203 | 'Argument of SQRT negative', & ! 2 204 | 'Argument of LOG negative ', & ! 3 205 | 'Argument of ASIN illegal ', & ! 4 206 | 'Argument of ACOS illegal ', & ! 5 207 | 'Invalid operation ' ] 208 | 209 | type stack_func_container 210 | !! to create an array of the function pointers in the fparser 211 | procedure(stack_func),pointer,nopass :: f => null() 212 | end type stack_func_container 213 | 214 | !**************************************************************** 215 | !> 216 | ! The function parser class. 217 | 218 | type,public :: fparser 219 | 220 | private 221 | 222 | type(stack_func_container),dimension(:),allocatable :: bytecode_ops !! array of function pointers 223 | integer,dimension(:),allocatable :: bytecode !! array of integers 224 | integer :: bytecodesize = 0 225 | 226 | real(wp),dimension(:),allocatable :: immed 227 | integer :: immedsize = 0 228 | 229 | real(wp),dimension(:),allocatable :: stack 230 | integer :: stacksize = 0 231 | integer :: stackptr = 0 232 | 233 | type(list_of_errors) :: error_msg !! list of error messages 234 | 235 | contains 236 | 237 | private 238 | 239 | procedure,public :: parse => parse_function 240 | procedure,public :: evaluate => evaluate_function 241 | procedure,public :: destroy => destroy_parser 242 | procedure,public :: error 243 | procedure,public :: print_errors 244 | procedure,public :: clear_errors 245 | 246 | procedure :: compile_substr 247 | procedure :: compile 248 | procedure :: check_syntax 249 | procedure :: add_error 250 | 251 | end type fparser 252 | !**************************************************************** 253 | 254 | !**************************************************************** 255 | !> 256 | ! A wrapper to [[fparser]] to evaluate an array of functions. 257 | ! 258 | !@note Each parser has the same variables. 259 | 260 | type,public :: fparser_array 261 | private 262 | type(fparser),dimension(:),allocatable :: f !! An array of parsers. 263 | !! Each one has the 264 | !! same variables. 265 | contains 266 | private 267 | procedure,public :: parse => parse_function_array 268 | procedure,public :: evaluate => evaluate_function_array 269 | procedure,public :: destroy => destroy_parser_array 270 | procedure,public :: error => error_array 271 | procedure,public :: print_errors => print_errors_array 272 | procedure,public :: clear_errors => clear_errors_array 273 | end type fparser_array 274 | !**************************************************************** 275 | 276 | !interface to functions: 277 | abstract interface 278 | subroutine stack_func(me,ip,dp,sp,val,ierr) 279 | !! a function that operates on the stack 280 | import :: wp,fparser 281 | implicit none 282 | class(fparser),intent(inout) :: me 283 | integer,intent(in) :: ip !! instruction pointer 284 | integer,intent(inout) :: dp !! data pointer 285 | integer,intent(inout) :: sp !! stack pointer 286 | real(wp),dimension(:),intent(in) :: val !! variable values 287 | integer,intent(out) :: ierr !! error flag 288 | end subroutine stack_func 289 | end interface 290 | 291 | contains 292 | !******************************************************************************* 293 | 294 | !******************************************************************************* 295 | !> 296 | ! Returns true if there are any errors in the class. 297 | 298 | pure elemental function error(me) 299 | 300 | implicit none 301 | 302 | class(fparser),intent(in) :: me 303 | logical :: error !! true if there are any errors in the class 304 | 305 | error = me%error_msg%has_errors() 306 | 307 | end function error 308 | !******************************************************************************* 309 | 310 | !******************************************************************************* 311 | !> 312 | ! Prints the error messages (if any) in the class. 313 | 314 | subroutine print_errors(me,iunit) 315 | 316 | implicit none 317 | 318 | class(fparser),intent(inout) :: me 319 | integer,intent(in) :: iunit !! unit number for printing 320 | !! (assumed to be open) 321 | 322 | call me%error_msg%print(iunit) 323 | 324 | end subroutine print_errors 325 | !******************************************************************************* 326 | 327 | !******************************************************************************* 328 | !> 329 | ! Clears any error messages in the class. 330 | 331 | pure elemental subroutine clear_errors(me) 332 | 333 | implicit none 334 | 335 | class(fparser),intent(inout) :: me 336 | 337 | call me%error_msg%destroy() 338 | 339 | end subroutine clear_errors 340 | !******************************************************************************* 341 | 342 | !******************************************************************************* 343 | !> 344 | ! Returns true if there are any errors in the class. 345 | 346 | pure elemental function error_array(me) 347 | 348 | implicit none 349 | 350 | class(fparser_array),intent(in) :: me 351 | logical :: error_array !! true if there are any errors in the class 352 | 353 | if (allocated(me%f)) then 354 | error_array = any(me%f%error()) 355 | else 356 | error_array = .false. 357 | end if 358 | 359 | end function error_array 360 | !******************************************************************************* 361 | 362 | !******************************************************************************* 363 | !> 364 | ! Prints the error messages (if any) in the class. 365 | 366 | subroutine print_errors_array(me,iunit) 367 | 368 | implicit none 369 | 370 | class(fparser_array),intent(inout) :: me 371 | integer,intent(in) :: iunit !! unit number for printing 372 | !! (assumed to be open) 373 | 374 | integer :: i !! counter 375 | 376 | if (allocated(me%f)) then 377 | do i=1, size(me%f) 378 | call me%f(i)%print_errors(iunit) 379 | end do 380 | end if 381 | 382 | end subroutine print_errors_array 383 | !******************************************************************************* 384 | 385 | !******************************************************************************* 386 | !> 387 | ! Clears any error messages in the class. 388 | 389 | pure elemental subroutine clear_errors_array(me) 390 | 391 | implicit none 392 | 393 | class(fparser_array),intent(inout) :: me 394 | 395 | integer :: i !! counter 396 | 397 | if (allocated(me%f)) then 398 | do i=1, size(me%f) 399 | call me%f(i)%clear_errors() 400 | end do 401 | end if 402 | 403 | end subroutine clear_errors_array 404 | !******************************************************************************* 405 | 406 | !******************************************************************************* 407 | !> 408 | ! [[fparser]] destructor. 409 | ! 410 | ! This can be called manually, and it is also called in [[parse_function]]. 411 | 412 | pure elemental subroutine destroy_parser(me) 413 | 414 | implicit none 415 | 416 | class(fparser),intent(inout) :: me 417 | 418 | if (allocated(me%bytecode)) deallocate(me%bytecode) 419 | if (allocated(me%immed)) deallocate(me%immed) 420 | if (allocated(me%stack)) deallocate(me%stack) 421 | if (allocated(me%bytecode_ops)) deallocate(me%bytecode_ops) 422 | 423 | call me%error_msg%destroy() 424 | 425 | end subroutine destroy_parser 426 | !******************************************************************************* 427 | 428 | !******************************************************************************* 429 | !> 430 | ! [[fparser_array]] destructor. 431 | 432 | pure elemental subroutine destroy_parser_array(me) 433 | 434 | implicit none 435 | 436 | class(fparser_array),intent(inout) :: me 437 | 438 | integer :: i !! counter 439 | 440 | if (allocated(me%f)) then 441 | do i=1,size(me%f) 442 | call me%f(i)%destroy() 443 | end do 444 | deallocate(me%f) 445 | end if 446 | 447 | end subroutine destroy_parser_array 448 | !******************************************************************************* 449 | 450 | !******************************************************************************* 451 | !> 452 | ! Parse the function string `funcstr` and compile it into bytecode 453 | 454 | subroutine parse_function (me, funcstr, var, case_sensitive) 455 | 456 | implicit none 457 | 458 | class(fparser),intent(inout) :: me 459 | character(len=*),intent(in) :: funcstr !! function string 460 | character(len=*), dimension(:), intent(in) :: var !! array with variable names 461 | logical,intent(in),optional :: case_sensitive !! are the variables case sensitive? 462 | !! [default is false] 463 | 464 | character (len=:),allocatable :: func !! function string, local use 465 | character(len=len(var)),dimension(size(var)) :: tmp_var !! variable list, local use 466 | integer,dimension(:),allocatable :: ipos 467 | 468 | logical :: is_case_sensitive 469 | integer :: k 470 | 471 | if (present(case_sensitive)) then 472 | is_case_sensitive = case_sensitive 473 | else 474 | is_case_sensitive = .false. 475 | end if 476 | 477 | !first, initialize: 478 | call me%destroy() 479 | 480 | !if is case insensitive, then convert both to lowercase: 481 | func = trim(adjustl(funcstr)) ! local copy of function string 482 | if (is_case_sensitive) then 483 | tmp_var = var 484 | else 485 | call to_lowercase (func, func) ! local copy of function string 486 | call to_lowercase (var, tmp_var) ! 487 | end if 488 | 489 | ! Allocate and initialize map from preprocessed function string to user input 490 | ! function string (used to print useful error messages). 491 | allocate (ipos(len_trim(funcstr))) 492 | ipos = [ (k,k=1,size(ipos)) ] 493 | 494 | !preprocess and check syntax: 495 | call replace_string ('**','^ ',func) ! exponent into 1-char. format 496 | call remove_spaces (func,ipos) ! condense function string 497 | call me%check_syntax(func,funcstr,tmp_var,ipos) 498 | 499 | ! Do not compile if `check_syntax` failed. 500 | if (.not. me%error()) then 501 | call me%compile(func,tmp_var) ! compile into bytecode 502 | end if 503 | 504 | deallocate (ipos) 505 | 506 | end subroutine parse_function 507 | !******************************************************************************* 508 | 509 | !******************************************************************************* 510 | !> 511 | ! Evaluate bytecode of function for the values passed in array `val`. 512 | 513 | subroutine evaluate_function (me, val, res) 514 | 515 | implicit none 516 | 517 | class(fparser),intent(inout) :: me 518 | real(wp), dimension(:), intent(in) :: val !! variable values 519 | real(wp),intent(out) :: res !! result 520 | 521 | integer :: ip !! instruction pointer 522 | integer :: dp !! data pointer 523 | integer :: sp !! stack pointer 524 | integer :: ierr !! error flag 525 | 526 | !initialize: 527 | dp = 1 528 | sp = 0 529 | 530 | !do all the operations: 531 | do ip=1,me%bytecodesize 532 | call me%bytecode_ops(ip)%f(me,ip,dp,sp,val,ierr) 533 | if (ierr/=0) then 534 | call me%error_msg%add(trim(get_error_message_string(ierr))) 535 | res = zero 536 | return 537 | end if 538 | end do 539 | 540 | !the result: 541 | res = me%stack(1) 542 | 543 | end subroutine evaluate_function 544 | !******************************************************************************* 545 | 546 | !******************************************************************************* 547 | !> 548 | ! Alternate version of [[parse_function]] for the [[fparser_array]] class. 549 | 550 | subroutine parse_function_array (me, funcstr, var, case_sensitive) 551 | 552 | implicit none 553 | 554 | class(fparser_array),intent(inout) :: me 555 | character(len=*),dimension(:),intent(in) :: funcstr !! function string array 556 | character(len=*),dimension(:),intent(in) :: var !! array with variable names 557 | logical,intent(in),optional :: case_sensitive !! are the variables case sensitive? 558 | !! [default is false] 559 | 560 | integer :: i !! counter 561 | integer :: n_funcs !! number of functions in the class 562 | 563 | !first, initialize: 564 | call me%destroy() 565 | 566 | n_funcs = size(funcstr) 567 | allocate(me%f(n_funcs)) 568 | 569 | do i=1,n_funcs 570 | call me%f(i)%parse(funcstr(i),var,case_sensitive) 571 | if (me%f(i)%error_msg%has_errors()) exit ! stop if there are any errors 572 | end do 573 | 574 | end subroutine parse_function_array 575 | !******************************************************************************* 576 | 577 | !******************************************************************************* 578 | !> 579 | ! Alternate version of [[evaluate_function]] for the [[fparser_array]] class. 580 | 581 | subroutine evaluate_function_array (me, val, res) 582 | 583 | implicit none 584 | 585 | class(fparser_array),intent(inout) :: me 586 | real(wp), dimension(:), intent(in) :: val !! variable values 587 | real(wp),dimension(:),intent(out) :: res !! result. Should be `size(me%f)` 588 | 589 | integer :: i !! counter 590 | integer :: n_funcs !! number of functions in the class 591 | 592 | if (allocated(me%f)) then 593 | n_funcs = size(me%f) 594 | if (n_funcs == size(res)) then 595 | do i=1,n_funcs 596 | call me%f(i)%evaluate(val,res(i)) 597 | if (me%f(i)%error_msg%has_errors()) exit ! stop if there are any errors 598 | end do 599 | else 600 | call me%f(i)%error_msg%add('Error: the res vector is not the correct size.') 601 | res = zero 602 | end if 603 | else 604 | call me%f(i)%error_msg%add('Error: the fparser_array has not been initialized.') 605 | res = zero 606 | end if 607 | 608 | end subroutine evaluate_function_array 609 | !******************************************************************************* 610 | 611 | !****************************************************************** 612 | subroutine cimmed_func(me,ip,dp,sp,val,ierr) 613 | 614 | implicit none 615 | 616 | class(fparser),intent(inout) :: me 617 | integer,intent(in) :: ip !! instruction pointer 618 | integer,intent(inout) :: dp !! data pointer 619 | integer,intent(inout) :: sp !! stack pointer 620 | real(wp),dimension(:),intent(in) :: val !! variable values 621 | integer,intent(out) :: ierr !! error flag 622 | 623 | sp=sp+1 624 | me%stack(sp) = me%immed(dp) 625 | dp=dp+1 626 | ierr = 0 627 | 628 | end subroutine cimmed_func 629 | !****************************************************************** 630 | 631 | !****************************************************************** 632 | !> 633 | ! Negative function 634 | 635 | subroutine cneg_func(me,ip,dp,sp,val,ierr) 636 | 637 | implicit none 638 | 639 | class(fparser),intent(inout) :: me 640 | integer,intent(in) :: ip !! instruction pointer 641 | integer,intent(inout) :: dp !! data pointer 642 | integer,intent(inout) :: sp !! stack pointer 643 | real(wp),dimension(:),intent(in) :: val !! variable values 644 | integer,intent(out) :: ierr !! error flag 645 | 646 | me%stack(sp) = -me%stack(sp) 647 | ierr = 0 648 | 649 | end subroutine cneg_func 650 | !****************************************************************** 651 | 652 | !****************************************************************** 653 | !> 654 | ! Add function 655 | 656 | subroutine cadd_func(me,ip,dp,sp,val,ierr) 657 | 658 | implicit none 659 | 660 | class(fparser),intent(inout) :: me 661 | integer,intent(in) :: ip !! instruction pointer 662 | integer,intent(inout) :: dp !! data pointer 663 | integer,intent(inout) :: sp !! stack pointer 664 | real(wp),dimension(:),intent(in) :: val !! variable values 665 | integer,intent(out) :: ierr !! error flag 666 | 667 | me%stack(sp-1) = me%stack(sp-1) + me%stack(sp) 668 | sp=sp-1 669 | ierr = 0 670 | 671 | end subroutine cadd_func 672 | !****************************************************************** 673 | 674 | !****************************************************************** 675 | !> 676 | ! Subtract function 677 | 678 | subroutine csub_func(me,ip,dp,sp,val,ierr) 679 | 680 | implicit none 681 | 682 | class(fparser),intent(inout) :: me 683 | integer,intent(in) :: ip !! instruction pointer 684 | integer,intent(inout) :: dp !! data pointer 685 | integer,intent(inout) :: sp !! stack pointer 686 | real(wp),dimension(:),intent(in) :: val !! variable values 687 | integer,intent(out) :: ierr !! error flag 688 | 689 | me%stack(sp-1) = me%stack(sp-1) - me%stack(sp) 690 | sp=sp-1 691 | ierr = 0 692 | 693 | end subroutine csub_func 694 | !****************************************************************** 695 | 696 | !****************************************************************** 697 | !> 698 | ! Multiply function 699 | 700 | subroutine cmul_func(me,ip,dp,sp,val,ierr) 701 | 702 | implicit none 703 | 704 | class(fparser),intent(inout) :: me 705 | integer,intent(in) :: ip !! instruction pointer 706 | integer,intent(inout) :: dp !! data pointer 707 | integer,intent(inout) :: sp !! stack pointer 708 | real(wp),dimension(:),intent(in) :: val !! variable values 709 | integer,intent(out) :: ierr !! error flag 710 | 711 | me%stack(sp-1) = me%stack(sp-1) * me%stack(sp) 712 | sp=sp-1 713 | ierr = 0 714 | 715 | end subroutine cmul_func 716 | !****************************************************************** 717 | 718 | !****************************************************************** 719 | !> 720 | ! Division function 721 | 722 | subroutine cdiv_func(me,ip,dp,sp,val,ierr) 723 | 724 | implicit none 725 | 726 | class(fparser),intent(inout) :: me 727 | integer,intent(in) :: ip !! instruction pointer 728 | integer,intent(inout) :: dp !! data pointer 729 | integer,intent(inout) :: sp !! stack pointer 730 | real(wp),dimension(:),intent(in) :: val !! variable values 731 | integer,intent(out) :: ierr !! error flag 732 | 733 | if (me%stack(sp)==zero) then 734 | 735 | ierr = error_div_by_zero !divide by zero error 736 | 737 | else 738 | 739 | me%stack(sp-1) = me%stack(sp-1)/me%stack(sp) 740 | sp=sp-1 741 | ierr = 0 742 | 743 | end if 744 | 745 | end subroutine cdiv_func 746 | !****************************************************************** 747 | 748 | !****************************************************************** 749 | !> 750 | ! Power 751 | 752 | subroutine cpow_func(me,ip,dp,sp,val,ierr) 753 | 754 | implicit none 755 | 756 | class(fparser),intent(inout) :: me 757 | integer,intent(in) :: ip !! instruction pointer 758 | integer,intent(inout) :: dp !! data pointer 759 | integer,intent(inout) :: sp !! stack pointer 760 | real(wp),dimension(:),intent(in) :: val !! variable values 761 | integer,intent(out) :: ierr !! error flag 762 | 763 | me%stack(sp-1) = me%stack(sp-1)**me%stack(sp) 764 | sp=sp-1 765 | ierr = 0 766 | 767 | end subroutine cpow_func 768 | !****************************************************************** 769 | 770 | !****************************************************************** 771 | !> 772 | ! Absolute value function 773 | 774 | subroutine cabs_func(me,ip,dp,sp,val,ierr) 775 | 776 | implicit none 777 | 778 | class(fparser),intent(inout) :: me 779 | integer,intent(in) :: ip !! instruction pointer 780 | integer,intent(inout) :: dp !! data pointer 781 | integer,intent(inout) :: sp !! stack pointer 782 | real(wp),dimension(:),intent(in) :: val !! variable values 783 | integer,intent(out) :: ierr !! error flag 784 | 785 | me%stack(sp) = abs(me%stack(sp)) 786 | ierr = 0 787 | 788 | end subroutine cabs_func 789 | !****************************************************************** 790 | 791 | !****************************************************************** 792 | !> 793 | ! Exponential function 794 | 795 | subroutine cexp_func(me,ip,dp,sp,val,ierr) 796 | 797 | implicit none 798 | 799 | class(fparser),intent(inout) :: me 800 | integer,intent(in) :: ip !! instruction pointer 801 | integer,intent(inout) :: dp !! data pointer 802 | integer,intent(inout) :: sp !! stack pointer 803 | real(wp),dimension(:),intent(in) :: val !! variable values 804 | integer,intent(out) :: ierr !! error flag 805 | 806 | me%stack(sp) = exp(me%stack(sp)) 807 | ierr = 0 808 | 809 | end subroutine cexp_func 810 | !****************************************************************** 811 | 812 | !****************************************************************** 813 | !> 814 | ! log10 function 815 | 816 | subroutine clog10_func(me,ip,dp,sp,val,ierr) 817 | 818 | implicit none 819 | 820 | class(fparser),intent(inout) :: me 821 | integer,intent(in) :: ip !! instruction pointer 822 | integer,intent(inout) :: dp !! data pointer 823 | integer,intent(inout) :: sp !! stack pointer 824 | real(wp),dimension(:),intent(in) :: val !! variable values 825 | integer,intent(out) :: ierr !! error flag 826 | 827 | if (me%stack(sp)<=zero) then 828 | ierr = error_log_arg_neg 829 | else 830 | me%stack(sp) = log10(me%stack(sp)) 831 | ierr = 0 832 | end if 833 | 834 | end subroutine clog10_func 835 | !****************************************************************** 836 | 837 | !****************************************************************** 838 | !> 839 | ! log function 840 | 841 | subroutine clog_func(me,ip,dp,sp,val,ierr) 842 | 843 | implicit none 844 | 845 | class(fparser),intent(inout) :: me 846 | integer,intent(in) :: ip !! instruction pointer 847 | integer,intent(inout) :: dp !! data pointer 848 | integer,intent(inout) :: sp !! stack pointer 849 | real(wp),dimension(:),intent(in) :: val !! variable values 850 | integer,intent(out) :: ierr !! error flag 851 | 852 | if (me%stack(sp)<=zero) then 853 | ierr = error_log_arg_neg 854 | else 855 | me%stack(sp)=log(me%stack(sp)) 856 | ierr = 0 857 | end if 858 | 859 | end subroutine clog_func 860 | !****************************************************************** 861 | 862 | !****************************************************************** 863 | !> 864 | ! square root function 865 | 866 | subroutine csqrt_func(me,ip,dp,sp,val,ierr) 867 | 868 | implicit none 869 | 870 | class(fparser),intent(inout) :: me 871 | integer,intent(in) :: ip !! instruction pointer 872 | integer,intent(inout) :: dp !! data pointer 873 | integer,intent(inout) :: sp !! stack pointer 874 | real(wp),dimension(:),intent(in) :: val !! variable values 875 | integer,intent(out) :: ierr !! error flag 876 | 877 | if (me%stack(sp) 889 | ! sinh function 890 | 891 | subroutine csinh_func(me,ip,dp,sp,val,ierr) 892 | 893 | implicit none 894 | 895 | class(fparser),intent(inout) :: me 896 | integer,intent(in) :: ip !! instruction pointer 897 | integer,intent(inout) :: dp !! data pointer 898 | integer,intent(inout) :: sp !! stack pointer 899 | real(wp),dimension(:),intent(in) :: val !! variable values 900 | integer,intent(out) :: ierr !! error flag 901 | 902 | me%stack(sp) = sinh(me%stack(sp)) 903 | ierr = 0 904 | 905 | end subroutine csinh_func 906 | !****************************************************************** 907 | 908 | !****************************************************************** 909 | !> 910 | ! cosh function 911 | 912 | subroutine ccosh_func(me,ip,dp,sp,val,ierr) 913 | 914 | implicit none 915 | 916 | class(fparser),intent(inout) :: me 917 | integer,intent(in) :: ip !! instruction pointer 918 | integer,intent(inout) :: dp !! data pointer 919 | integer,intent(inout) :: sp !! stack pointer 920 | real(wp),dimension(:),intent(in) :: val !! variable values 921 | integer,intent(out) :: ierr !! error flag 922 | 923 | me%stack(sp) = cosh(me%stack(sp)) 924 | ierr = 0 925 | 926 | end subroutine ccosh_func 927 | !****************************************************************** 928 | 929 | !****************************************************************** 930 | !> 931 | ! tanh function 932 | 933 | subroutine ctanh_func(me,ip,dp,sp,val,ierr) 934 | 935 | implicit none 936 | 937 | class(fparser),intent(inout) :: me 938 | integer,intent(in) :: ip !! instruction pointer 939 | integer,intent(inout) :: dp !! data pointer 940 | integer,intent(inout) :: sp !! stack pointer 941 | real(wp),dimension(:),intent(in) :: val !! variable values 942 | integer,intent(out) :: ierr !! error flag 943 | 944 | me%stack(sp) = tanh(me%stack(sp)) 945 | ierr = 0 946 | 947 | end subroutine ctanh_func 948 | !****************************************************************** 949 | 950 | !****************************************************************** 951 | !> 952 | ! sin function 953 | 954 | subroutine csin_func(me,ip,dp,sp,val,ierr) 955 | 956 | implicit none 957 | 958 | class(fparser),intent(inout) :: me 959 | integer,intent(in) :: ip !! instruction pointer 960 | integer,intent(inout) :: dp !! data pointer 961 | integer,intent(inout) :: sp !! stack pointer 962 | real(wp),dimension(:),intent(in) :: val !! variable values 963 | integer,intent(out) :: ierr !! error flag 964 | 965 | me%stack(sp) = sin(me%stack(sp)) 966 | ierr = 0 967 | 968 | end subroutine csin_func 969 | !****************************************************************** 970 | 971 | !****************************************************************** 972 | !> 973 | ! cos function 974 | 975 | subroutine ccos_func(me,ip,dp,sp,val,ierr) 976 | 977 | implicit none 978 | 979 | class(fparser),intent(inout) :: me 980 | integer,intent(in) :: ip !! instruction pointer 981 | integer,intent(inout) :: dp !! data pointer 982 | integer,intent(inout) :: sp !! stack pointer 983 | real(wp),dimension(:),intent(in) :: val !! variable values 984 | integer,intent(out) :: ierr !! error flag 985 | 986 | me%stack(sp) = cos(me%stack(sp)) 987 | ierr = 0 988 | 989 | end subroutine ccos_func 990 | !****************************************************************** 991 | 992 | !****************************************************************** 993 | !> 994 | ! tan function 995 | 996 | subroutine ctan_func(me,ip,dp,sp,val,ierr) 997 | 998 | implicit none 999 | 1000 | class(fparser),intent(inout) :: me 1001 | integer,intent(in) :: ip !! instruction pointer 1002 | integer,intent(inout) :: dp !! data pointer 1003 | integer,intent(inout) :: sp !! stack pointer 1004 | real(wp),dimension(:),intent(in) :: val !! variable values 1005 | integer,intent(out) :: ierr !! error flag 1006 | 1007 | me%stack(sp) = tan(me%stack(sp)) 1008 | ierr = 0 1009 | 1010 | end subroutine ctan_func 1011 | !****************************************************************** 1012 | 1013 | !****************************************************************** 1014 | !> 1015 | ! asin function 1016 | 1017 | subroutine casin_func(me,ip,dp,sp,val,ierr) 1018 | 1019 | implicit none 1020 | 1021 | class(fparser),intent(inout) :: me 1022 | integer,intent(in) :: ip !! instruction pointer 1023 | integer,intent(inout) :: dp !! data pointer 1024 | integer,intent(inout) :: sp !! stack pointer 1025 | real(wp),dimension(:),intent(in) :: val !! variable values 1026 | integer,intent(out) :: ierr !! error flag 1027 | 1028 | if ((me%stack(sp)<-one).or.(me%stack(sp)>one)) then 1029 | ierr = error_asin_arg_illegal 1030 | else 1031 | me%stack(sp)=asin(me%stack(sp)) 1032 | ierr = 0 1033 | end if 1034 | 1035 | end subroutine casin_func 1036 | !****************************************************************** 1037 | 1038 | !****************************************************************** 1039 | !> 1040 | ! acos function 1041 | 1042 | subroutine cacos_func(me,ip,dp,sp,val,ierr) 1043 | 1044 | implicit none 1045 | 1046 | class(fparser),intent(inout) :: me 1047 | integer,intent(in) :: ip !! instruction pointer 1048 | integer,intent(inout) :: dp !! data pointer 1049 | integer,intent(inout) :: sp !! stack pointer 1050 | real(wp),dimension(:),intent(in) :: val !! variable values 1051 | integer,intent(out) :: ierr !! error flag 1052 | 1053 | if ((me%stack(sp)<-one).or.(me%stack(sp)>one)) then 1054 | ierr = error_acos_arg_illegal 1055 | else 1056 | me%stack(sp) = acos(me%stack(sp)) 1057 | ierr = 0 1058 | end if 1059 | 1060 | end subroutine cacos_func 1061 | !****************************************************************** 1062 | 1063 | !****************************************************************** 1064 | !> 1065 | ! atan function 1066 | 1067 | subroutine catan_func(me,ip,dp,sp,val,ierr) 1068 | 1069 | implicit none 1070 | 1071 | class(fparser),intent(inout) :: me 1072 | integer,intent(in) :: ip !! instruction pointer 1073 | integer,intent(inout) :: dp !! data pointer 1074 | integer,intent(inout) :: sp !! stack pointer 1075 | real(wp),dimension(:),intent(in) :: val !! variable values 1076 | integer,intent(out) :: ierr !! error flag 1077 | 1078 | me%stack(sp)=atan(me%stack(sp)) 1079 | ierr = 0 1080 | 1081 | end subroutine catan_func 1082 | !****************************************************************** 1083 | 1084 | !****************************************************************** 1085 | !> 1086 | ! atan2 function 1087 | 1088 | subroutine catan2_func(me,ip,dp,sp,val,ierr) 1089 | 1090 | implicit none 1091 | 1092 | class(fparser),intent(inout) :: me 1093 | integer,intent(in) :: ip !! instruction pointer 1094 | integer,intent(inout) :: dp !! data pointer 1095 | integer,intent(inout) :: sp !! stack pointer 1096 | real(wp),dimension(:),intent(in) :: val !! variable values 1097 | integer,intent(out) :: ierr !! error flag 1098 | 1099 | me%stack(sp-1) = atan2(me%stack(sp-1), me%stack(sp)) 1100 | sp = sp - 1 1101 | ierr = 0 1102 | 1103 | end subroutine catan2_func 1104 | !****************************************************************** 1105 | 1106 | !****************************************************************** 1107 | !> 1108 | ! Pi. A function with zero arguments. 1109 | 1110 | subroutine cPi_func(me,ip,dp,sp,val,ierr) 1111 | 1112 | implicit none 1113 | 1114 | class(fparser),intent(inout) :: me 1115 | integer,intent(in) :: ip !! instruction pointer 1116 | integer,intent(inout) :: dp !! data pointer 1117 | integer,intent(inout) :: sp !! stack pointer 1118 | real(wp),dimension(:),intent(in) :: val !! variable values 1119 | integer,intent(out) :: ierr !! error flag 1120 | 1121 | sp = sp + 1 1122 | me%stack(sp) = pi 1123 | ierr = 0 1124 | 1125 | end subroutine cPi_func 1126 | !****************************************************************** 1127 | 1128 | !****************************************************************** 1129 | !> 1130 | ! ceiling function 1131 | 1132 | subroutine cceil_func(me,ip,dp,sp,val,ierr) 1133 | 1134 | implicit none 1135 | 1136 | class(fparser),intent(inout) :: me 1137 | integer,intent(in) :: ip !! instruction pointer 1138 | integer,intent(inout) :: dp !! data pointer 1139 | integer,intent(inout) :: sp !! stack pointer 1140 | real(wp),dimension(:),intent(in) :: val !! variable values 1141 | integer,intent(out) :: ierr !! error flag 1142 | 1143 | me%stack(sp) = ceiling(me%stack(sp)) 1144 | ierr = 0 1145 | 1146 | end subroutine cceil_func 1147 | !****************************************************************** 1148 | 1149 | !****************************************************************** 1150 | !> 1151 | ! floor function 1152 | 1153 | subroutine cfloor_func(me,ip,dp,sp,val,ierr) 1154 | 1155 | implicit none 1156 | 1157 | class(fparser),intent(inout) :: me 1158 | integer,intent(in) :: ip !! instruction pointer 1159 | integer,intent(inout) :: dp !! data pointer 1160 | integer,intent(inout) :: sp !! stack pointer 1161 | real(wp),dimension(:),intent(in) :: val !! variable values 1162 | integer,intent(out) :: ierr !! error flag 1163 | 1164 | me%stack(sp) = floor(me%stack(sp)) 1165 | ierr = 0 1166 | 1167 | end subroutine cfloor_func 1168 | !****************************************************************** 1169 | 1170 | !****************************************************************** 1171 | !> 1172 | ! gamma function 1173 | 1174 | subroutine cgamma_func(me,ip,dp,sp,val,ierr) 1175 | 1176 | implicit none 1177 | 1178 | class(fparser),intent(inout) :: me 1179 | integer,intent(in) :: ip !! instruction pointer 1180 | integer,intent(inout) :: dp !! data pointer 1181 | integer,intent(inout) :: sp !! stack pointer 1182 | real(wp),dimension(:),intent(in) :: val !! variable values 1183 | integer,intent(out) :: ierr !! error flag 1184 | 1185 | me%stack(sp) = gamma(me%stack(sp)) 1186 | ierr = 0 1187 | 1188 | end subroutine cgamma_func 1189 | !****************************************************************** 1190 | 1191 | !****************************************************************** 1192 | !> 1193 | ! hypot function 1194 | 1195 | subroutine chypot_func(me,ip,dp,sp,val,ierr) 1196 | 1197 | implicit none 1198 | 1199 | class(fparser),intent(inout) :: me 1200 | integer,intent(in) :: ip !! instruction pointer 1201 | integer,intent(inout) :: dp !! data pointer 1202 | integer,intent(inout) :: sp !! stack pointer 1203 | real(wp),dimension(:),intent(in) :: val !! variable values 1204 | integer,intent(out) :: ierr !! error flag 1205 | 1206 | me%stack(sp-1) = hypot(me%stack(sp-1), me%stack(sp)) 1207 | sp = sp - 1 1208 | ierr = 0 1209 | 1210 | end subroutine chypot_func 1211 | !****************************************************************** 1212 | 1213 | !****************************************************************** 1214 | !> 1215 | ! max function 1216 | 1217 | subroutine cmax_func(me,ip,dp,sp,val,ierr) 1218 | 1219 | implicit none 1220 | 1221 | class(fparser),intent(inout) :: me 1222 | integer,intent(in) :: ip !! instruction pointer 1223 | integer,intent(inout) :: dp !! data pointer 1224 | integer,intent(inout) :: sp !! stack pointer 1225 | real(wp),dimension(:),intent(in) :: val !! variable values 1226 | integer,intent(out) :: ierr !! error flag 1227 | 1228 | me%stack(sp-1) = max(me%stack(sp-1), me%stack(sp)) 1229 | sp = sp - 1 1230 | ierr = 0 1231 | 1232 | end subroutine cmax_func 1233 | !****************************************************************** 1234 | 1235 | !****************************************************************** 1236 | !> 1237 | ! min function 1238 | 1239 | subroutine cmin_func(me,ip,dp,sp,val,ierr) 1240 | 1241 | implicit none 1242 | 1243 | class(fparser),intent(inout) :: me 1244 | integer,intent(in) :: ip !! instruction pointer 1245 | integer,intent(inout) :: dp !! data pointer 1246 | integer,intent(inout) :: sp !! stack pointer 1247 | real(wp),dimension(:),intent(in) :: val !! variable values 1248 | integer,intent(out) :: ierr !! error flag 1249 | 1250 | me%stack(sp-1) = min(me%stack(sp-1), me%stack(sp)) 1251 | sp = sp - 1 1252 | ierr = 0 1253 | 1254 | end subroutine cmin_func 1255 | !****************************************************************** 1256 | 1257 | !****************************************************************** 1258 | !> 1259 | ! mod function 1260 | 1261 | subroutine cmod_func(me,ip,dp,sp,val,ierr) 1262 | 1263 | implicit none 1264 | 1265 | class(fparser),intent(inout) :: me 1266 | integer,intent(in) :: ip !! instruction pointer 1267 | integer,intent(inout) :: dp !! data pointer 1268 | integer,intent(inout) :: sp !! stack pointer 1269 | real(wp),dimension(:),intent(in) :: val !! variable values 1270 | integer,intent(out) :: ierr !! error flag 1271 | 1272 | me%stack(sp-1) = mod(me%stack(sp-1), me%stack(sp)) 1273 | sp = sp - 1 1274 | ierr = 0 1275 | 1276 | end subroutine cmod_func 1277 | !****************************************************************** 1278 | 1279 | !****************************************************************** 1280 | !> 1281 | ! modulo function 1282 | 1283 | subroutine cmodulo_func(me,ip,dp,sp,val,ierr) 1284 | 1285 | implicit none 1286 | 1287 | class(fparser),intent(inout) :: me 1288 | integer,intent(in) :: ip !! instruction pointer 1289 | integer,intent(inout) :: dp !! data pointer 1290 | integer,intent(inout) :: sp !! stack pointer 1291 | real(wp),dimension(:),intent(in) :: val !! variable values 1292 | integer,intent(out) :: ierr !! error flag 1293 | 1294 | me%stack(sp-1) = modulo(me%stack(sp-1), me%stack(sp)) 1295 | sp = sp - 1 1296 | ierr = 0 1297 | 1298 | end subroutine cmodulo_func 1299 | !****************************************************************** 1300 | 1301 | !****************************************************************** 1302 | !> 1303 | ! sign function 1304 | 1305 | subroutine csign_func(me,ip,dp,sp,val,ierr) 1306 | 1307 | implicit none 1308 | 1309 | class(fparser),intent(inout) :: me 1310 | integer,intent(in) :: ip !! instruction pointer 1311 | integer,intent(inout) :: dp !! data pointer 1312 | integer,intent(inout) :: sp !! stack pointer 1313 | real(wp),dimension(:),intent(in) :: val !! variable values 1314 | integer,intent(out) :: ierr !! error flag 1315 | 1316 | me%stack(sp-1) = sign(me%stack(sp-1), me%stack(sp)) 1317 | sp = sp - 1 1318 | ierr = 0 1319 | 1320 | end subroutine csign_func 1321 | !****************************************************************** 1322 | 1323 | !****************************************************************** 1324 | !> 1325 | ! If function with three arguments. 1326 | ! 1327 | ! `If(expression, value is true, value if false)` 1328 | ! 1329 | ! Where: 0 is false and /=0 is true. 1330 | 1331 | subroutine cif_func(me,ip,dp,sp,val,ierr) 1332 | 1333 | implicit none 1334 | 1335 | class(fparser),intent(inout) :: me 1336 | integer,intent(in) :: ip !! instruction pointer 1337 | integer,intent(inout) :: dp !! data pointer 1338 | integer,intent(inout) :: sp !! stack pointer 1339 | real(wp),dimension(:),intent(in) :: val !! variable values 1340 | integer,intent(out) :: ierr !! error flag 1341 | 1342 | if (me%stack(sp-2) /= zero) then ! true 1343 | me%stack(sp-2) = me%stack(sp-1) 1344 | else ! false 1345 | me%stack(sp-2) = me%stack(sp) 1346 | end if 1347 | 1348 | sp = sp - 2 1349 | ierr = 0 1350 | 1351 | end subroutine cif_func 1352 | !****************************************************************** 1353 | 1354 | !****************************************************************** 1355 | subroutine cdefault_func(me,ip,dp,sp,val,ierr) 1356 | 1357 | implicit none 1358 | 1359 | class(fparser),intent(inout) :: me !! parser class 1360 | integer,intent(in) :: ip !! instruction pointer 1361 | integer,intent(inout) :: dp !! data pointer 1362 | integer,intent(inout) :: sp !! stack pointer 1363 | real(wp),dimension(:),intent(in) :: val !! variable values 1364 | integer,intent(out) :: ierr !! error flag 1365 | 1366 | sp=sp+1 1367 | me%stack(sp) = val(me%bytecode(ip)-varbegin+1) 1368 | ierr = 0 1369 | 1370 | end subroutine cdefault_func 1371 | !****************************************************************** 1372 | 1373 | !******************************************************************************* 1374 | !> 1375 | ! Find the end positions of each function argument. 1376 | ! 1377 | ! 12345678901234567890123456789012 1378 | ! For example, "funcWithThreeArgs(12.4,x,abs(x))" will result in an 1379 | ! 'arg_pos' of [22, 24, 31, 0, 0]. 1380 | ! 1381 | ! Errors returned: 1382 | ! 1 : Function's closing parenthesis is missing. 1383 | ! 2 : Function has more than `max_func_args` arguments. 1384 | ! 3 : Function has an empty argument. 1385 | 1386 | subroutine find_arg_positions(paren_start, func, num_args, arg_pos, ierr, err_pos) 1387 | 1388 | implicit none 1389 | 1390 | integer, intent(in) :: paren_start !! The position of the function's opening parenthesis. 1391 | character(len=*), intent(in) :: func !! Pre-processed function string (no spaces or '**'). 1392 | integer, intent(out) :: num_args !! The number of arguments found. 1393 | integer, dimension(max_func_args), intent(out) :: arg_pos !! The end positions of each argument. 1394 | integer, optional, intent(out) :: ierr !! Error code; non-zero if an error occurred. 1395 | integer, optional, intent(out) :: err_pos !! The position in `func` of an error; 0 unless `ierr` /= 0. 1396 | 1397 | integer, parameter :: missing_closing_paren = 1, & 1398 | too_many_args = 2, & 1399 | empty_arg = 3 1400 | 1401 | character(len=1) :: cur_char !! The current character in `func` being processed. 1402 | 1403 | integer :: cur_pos, & !! The current position in `func` being processed. 1404 | func_len, & !! The length of `func`. 1405 | open_parens, & !! The number of open parentheses. 1406 | arg_len, & !! The length of an argument. 1407 | iarg !! Argument index. 1408 | 1409 | ! Initialize outputs. 1410 | num_args = 1 1411 | arg_pos = 0 1412 | if (present(ierr)) ierr = 0 1413 | if (present(err_pos)) err_pos = 0 1414 | 1415 | func_len = len_trim(func) 1416 | open_parens = 1 1417 | 1418 | cur_pos = paren_start + 1 1419 | func_len = len_trim(func) 1420 | 1421 | ! Step through the function string until we find the function's closing parenthesis. 1422 | ! Every time we find a comma character at the same parentheses level as the function's 1423 | ! opening parenthesis, increment the number of arguments and record the previous 1424 | ! argument's last character. 1425 | do while (open_parens > 0) 1426 | if (cur_pos > func_len) then 1427 | ! The function did not have a closing parenthesis. 1428 | if (present(ierr)) ierr = missing_closing_paren 1429 | if (present(err_pos)) err_pos = func_len 1430 | return 1431 | end if 1432 | 1433 | cur_char = func(cur_pos:cur_pos) 1434 | 1435 | if (cur_char == '(') then 1436 | open_parens = open_parens + 1 1437 | 1438 | elseif (cur_char == ')') then 1439 | ! For a "functionWithNoArgs()" set num_args = 0 and return. 1440 | if (cur_pos == paren_start + 1) then 1441 | num_args = 0 1442 | return 1443 | end if 1444 | 1445 | open_parens = open_parens - 1 1446 | 1447 | ! We have arrived at the function's closing parenthesis. 1448 | if (open_parens == 0) arg_pos(num_args) = cur_pos - 1 1449 | 1450 | elseif (cur_char == ',') then 1451 | if (open_parens == 1) then 1452 | ! Check if we have exceeded the maximum allowed number of function 1453 | ! arguments. This is not checking that 'num_args' is necessarily 1454 | ! valid for a specific function. 1455 | if (num_args + 1 > max_func_args) then 1456 | if (present(ierr)) ierr = too_many_args 1457 | if (present(err_pos)) err_pos = cur_pos 1458 | return 1459 | endif 1460 | 1461 | arg_pos(num_args) = cur_pos - 1 1462 | num_args = num_args + 1 1463 | end if 1464 | end if 1465 | 1466 | cur_pos = cur_pos + 1 1467 | end do 1468 | 1469 | ! Check for empty arguments. 1470 | do iarg = 1, num_args 1471 | if (iarg == 1) then 1472 | arg_len = arg_pos(iarg) - paren_start 1473 | else 1474 | arg_len = arg_pos(iarg) - arg_pos(iarg - 1) - 1 1475 | endif 1476 | 1477 | if (arg_len == 0) then 1478 | if (present(ierr)) ierr = empty_arg 1479 | if (present(err_pos)) err_pos = arg_pos(iarg) 1480 | return 1481 | end if 1482 | end do 1483 | 1484 | end subroutine find_arg_positions 1485 | !******************************************************************************* 1486 | 1487 | !******************************************************************************* 1488 | !> 1489 | ! Check syntax of function string. 1490 | 1491 | recursive subroutine check_syntax (me,func,funcstr,var,ipos) 1492 | 1493 | implicit none 1494 | 1495 | class(fparser),intent(inout) :: me 1496 | character(len=*),intent(in) :: func !! function string without spaces 1497 | character(len=*),intent(in) :: funcstr !! original function string 1498 | character(len=*), dimension(:),intent(in) :: var !! array with variable names 1499 | integer,dimension(:),intent(in) :: ipos 1500 | 1501 | integer :: n 1502 | character(len=1) :: c 1503 | real(wp) :: r 1504 | logical :: err 1505 | integer :: parcnt !! parenthesis counter 1506 | integer :: j,ib,in,lFunc 1507 | integer :: arg_pos(max_func_args) 1508 | integer :: num_args, iarg 1509 | integer :: ierr, err_pos 1510 | integer :: func_arg_ipos(size(ipos)) 1511 | integer :: arg_start, arg_end 1512 | logical :: end_of_function 1513 | 1514 | lFunc = len_trim(func) 1515 | 1516 | ! Initial loop over function to verify matched parentheses. This slightly 1517 | ! increases runtime but allows for improved error reporting. 1518 | parcnt = 0 1519 | do j = 1, lFunc 1520 | c = func(j:j) 1521 | if (c == '(') then 1522 | parcnt = parcnt + 1 1523 | elseif (c == ')') then 1524 | parcnt = parcnt - 1 1525 | end if 1526 | 1527 | if (parcnt < 0) then 1528 | call me%add_error(j, ipos, funcstr, 'Missing opening parenthesis') 1529 | return 1530 | end if 1531 | end do 1532 | 1533 | if (parcnt /= 0) then 1534 | call me%add_error(lFunc, ipos, funcstr, 'Missing closing parenthesis') 1535 | return 1536 | endif 1537 | 1538 | j = 1 1539 | step: do 1540 | if (j > lFunc) then 1541 | call me%add_error(j, ipos, funcstr) 1542 | return 1543 | end if 1544 | 1545 | c = func(j:j) 1546 | ! Check for valid operand (must appear) 1547 | if (c == '-' .or. c == '+') then ! Check for leading - or + 1548 | j = j+1 1549 | if (j > lFunc) then 1550 | call me%add_error(j, ipos, funcstr, 'Missing operand') 1551 | return 1552 | end if 1553 | c = func(j:j) 1554 | if (any(c == operators)) then 1555 | call me%add_error(j, ipos, funcstr, 'Multiple operators') 1556 | return 1557 | end if 1558 | end if 1559 | 1560 | end_of_function = .false. 1561 | n = mathfunction_index (func(j:), var) 1562 | if (n > 0) then ! Check for math function 1563 | j = j+len_trim(functions(n)) 1564 | if (j > lFunc) then 1565 | call me%add_error(j, ipos, funcstr, 'Missing function argument') 1566 | return 1567 | end if 1568 | c = func(j:j) 1569 | if (c /= '(') then 1570 | call me%add_error(j, ipos, funcstr, 'Missing opening parenthesis') 1571 | return 1572 | end if 1573 | 1574 | ! Find the number of function arguments and argument substring positions 1575 | ! in `func`. 1576 | call find_arg_positions(j, func, num_args, arg_pos, ierr, err_pos) 1577 | if (ierr /= 0) then 1578 | select case (ierr) 1579 | case (1); call me%add_error(err_pos, ipos, funcstr, 'Missing function closing parenthesis') 1580 | case (2); call me%add_error(err_pos, ipos, funcstr, 'Function has too many arguments') 1581 | case (3); call me%add_error(err_pos, ipos, funcstr, 'Function has an empty argument') 1582 | case default; call me%add_error(err_pos, ipos, funcstr, 'Unknown find argument position error') 1583 | end select 1584 | return 1585 | end if 1586 | 1587 | ! Verify that the number of function arguments present is consistent 1588 | ! with the specified function. 1589 | if (num_args < required_args(n)) then 1590 | call me%add_error(j, ipos, funcstr, 'Missing required function argument') 1591 | return 1592 | elseif (num_args > required_args(n) + optional_args(n)) then 1593 | call me%add_error(j, ipos, funcstr, 'Too many function arguments') 1594 | return 1595 | end if 1596 | 1597 | ! Recursively check each argument substring. 1598 | if (num_args == 0) then 1599 | j = j + 2 1600 | else 1601 | do iarg = 1, num_args 1602 | if (iarg == 1) then 1603 | arg_start = j + 1 1604 | else 1605 | arg_start = arg_pos(iarg-1) + 2 1606 | endif 1607 | 1608 | arg_end = arg_pos(iarg) 1609 | func_arg_ipos(1:(arg_end-arg_start+1)) = ipos(arg_start:arg_end) 1610 | 1611 | call me%check_syntax(func(arg_start:arg_end), funcstr, var, func_arg_ipos) 1612 | if (me%error()) return 1613 | end do 1614 | 1615 | j = arg_pos(num_args) + 2 1616 | endif 1617 | 1618 | if (j > lFunc) exit 1619 | c = func(j:j) 1620 | 1621 | ! We've moved past the closing parenthesis of "someFunction(...)", so 1622 | ! next we either need an operator or a closing parenthesis. 1623 | end_of_function = .true. 1624 | end if 1625 | 1626 | if (.not. end_of_function) then 1627 | if (c == '(') then ! Check for opening parenthesis 1628 | parcnt = parcnt+1 1629 | j = j+1 1630 | cycle step 1631 | end if 1632 | 1633 | if (scan(c,'0123456789.') > 0) then ! Check for number 1634 | r = string_to_real (func(j:),ib,in,err) 1635 | if (err) then 1636 | call me%add_error(j, ipos, funcstr, 'Invalid number format: '//func(j+ib-1:j+in-2)) 1637 | return 1638 | end if 1639 | j = j+in-1 1640 | if (j > lFunc) exit 1641 | c = func(j:j) 1642 | else ! Check for variable 1643 | n = variable_index (func(j:),Var,ib,in) 1644 | if (n == 0) then 1645 | call me%add_error(j, ipos, funcstr, 'Invalid element: '//func(j+ib-1:j+in-2)) 1646 | return 1647 | end if 1648 | j = j+in-1 1649 | if (j > lFunc) exit 1650 | c = func(j:j) 1651 | end if 1652 | end if 1653 | 1654 | do while (c == ')') ! Check for closing parenthesis 1655 | parcnt = parcnt-1 1656 | if (parcnt < 0) then 1657 | call me%add_error(j, ipos, funcstr, 'Mismatched parenthesis') 1658 | return 1659 | end if 1660 | if (func(j-1:j-1) == '(') then 1661 | call me%add_error(j-1, ipos, funcstr, 'Empty parentheses') 1662 | return 1663 | end if 1664 | j = j+1 1665 | if (j > lFunc) exit 1666 | c = func(j:j) 1667 | end do 1668 | 1669 | ! Now, we have a legal operand: A legal operator or end of string must follow 1670 | if (j > lFunc) exit 1671 | if (any(c == operators)) then ! Check for multiple operators 1672 | if (j+1 > lFunc) then 1673 | call me%add_error(j, ipos, funcstr) 1674 | return 1675 | end if 1676 | if (any(func(j+1:j+1) == operators)) then 1677 | call me%add_error(j+1, ipos, funcstr, 'Multiple operators') 1678 | return 1679 | end if 1680 | else ! Check for next operand 1681 | call me%add_error(j, ipos, funcstr, 'Missing operator') 1682 | return 1683 | end if 1684 | 1685 | ! Now, we have an operand and an operator: the next loop will check for another 1686 | ! operand (must appear) 1687 | j = j+1 1688 | end do step 1689 | 1690 | end subroutine check_syntax 1691 | !******************************************************************************* 1692 | 1693 | !******************************************************************************* 1694 | !> 1695 | ! return error message string, given the error code. 1696 | 1697 | function get_error_message_string (ierr) result (msg) 1698 | 1699 | implicit none 1700 | 1701 | integer,intent(in) :: ierr !! error message number 1702 | character (len=len(error_messages)) :: msg !! the error message string 1703 | 1704 | if (ierr == 0 .or. ierr > size(error_messages)) then 1705 | msg = '' 1706 | else 1707 | msg = error_messages(ierr) 1708 | endif 1709 | 1710 | end function get_error_message_string 1711 | !******************************************************************************* 1712 | 1713 | !******************************************************************************* 1714 | !> 1715 | ! add error message to the class. 1716 | 1717 | subroutine add_error (me, j, ipos, funcstr, msg) 1718 | 1719 | implicit none 1720 | 1721 | class(fparser),intent(inout) :: me 1722 | integer,intent(in) :: j 1723 | integer,dimension(:),intent(in) :: ipos 1724 | character(len=*),intent(in) :: funcstr !! original function string 1725 | character(len=*),optional,intent(in) :: msg 1726 | 1727 | character(len=:),allocatable :: tmp !! to indicate where on 1728 | !! the line the error occurs 1729 | 1730 | if (present(msg)) then 1731 | call me%error_msg%add('*** Error in syntax of function string: '//Msg) 1732 | else 1733 | call me%error_msg%add('*** Error in syntax of function string:') 1734 | endif 1735 | 1736 | call me%error_msg%add(' '//trim(funcstr)) 1737 | 1738 | tmp = repeat(' ',ipos(min(j,size(ipos))))//'?' ! Advance to the jth position 1739 | call me%error_msg%add(tmp) 1740 | deallocate(tmp) 1741 | 1742 | end subroutine add_error 1743 | !******************************************************************************* 1744 | 1745 | !******************************************************************************* 1746 | !> 1747 | ! return operator index 1748 | 1749 | function operator_index (c) result (n) 1750 | 1751 | implicit none 1752 | 1753 | character(len=1), intent(in) :: c 1754 | integer :: n 1755 | 1756 | integer :: j !! counter 1757 | 1758 | n = 0 1759 | do j=cadd,cpow 1760 | if (c == operators(j)) then 1761 | n = j 1762 | exit 1763 | end if 1764 | end do 1765 | 1766 | end function operator_index 1767 | !******************************************************************************* 1768 | 1769 | !******************************************************************************* 1770 | !> 1771 | ! Return index of math function beginning at 1st position of string `str` 1772 | 1773 | function mathfunction_index (str, var) result (n) 1774 | 1775 | implicit none 1776 | 1777 | character(len=*), intent(in) :: str 1778 | character(len=*), dimension(:),intent(in) :: var !! array with variable names 1779 | integer :: n 1780 | 1781 | integer :: j 1782 | integer :: k 1783 | character (len=len(functions)) :: fun 1784 | 1785 | n = 0 1786 | do j=cAbs,cIf ! check all math functions 1787 | k = min(len_trim(functions(j)), len(str)) 1788 | call to_lowercase (str(1:k), fun) 1789 | if (fun == functions(j)) then ! compare lower case letters 1790 | n = j ! found a matching function 1791 | exit 1792 | end if 1793 | end do 1794 | 1795 | if (n>0) then 1796 | if (any(functions(n) == var)) then 1797 | ! in this case, there is a variable with the same 1798 | ! name as this function. So, check to make sure this 1799 | ! is really the function. 1800 | if (k+1<=len(str)) then 1801 | if (str(k+1:k+1) /= '(') then ! this assumes that spaces have been removed 1802 | n = 0 ! assume it is the variable 1803 | end if 1804 | end if 1805 | end if 1806 | end if 1807 | 1808 | end function mathfunction_index 1809 | !******************************************************************************* 1810 | 1811 | !******************************************************************************* 1812 | !> 1813 | ! return index of variable at begin of string str (returns 0 if no variable found) 1814 | 1815 | function variable_index (str, var, ibegin, inext) result (n) 1816 | 1817 | implicit none 1818 | 1819 | character(len=*),intent(in) :: str !! string 1820 | character(len=*),dimension(:),intent(in) :: var !! array with variable names 1821 | integer :: n !! index of variable 1822 | integer, optional,intent(out) :: ibegin !! start position of variable name 1823 | integer, optional,intent(out) :: inext !! position of character after name 1824 | 1825 | integer :: j,ib,in,lstr 1826 | 1827 | n = 0 1828 | ib = 0 1829 | in = 0 1830 | lstr = len_trim(str) 1831 | if (lstr > 0) then 1832 | do ib=1,lstr ! search for first character in str 1833 | if (str(ib:ib) /= ' ') exit ! when lstr>0 at least 1 char in str 1834 | end do 1835 | do in=ib,lstr ! search for name terminators 1836 | if (scan(str(in:in),'+-*/^) ') > 0) exit ! NOTE: all the operators must be here [cAdd,cSub,cMul,cDiv,cPow] 1837 | end do 1838 | do j=1,size(var) 1839 | if (str(ib:in-1) == var(j)) then 1840 | n = j ! variable name found 1841 | exit 1842 | end if 1843 | end do 1844 | end if 1845 | if (present(ibegin)) ibegin = ib 1846 | if (present(inext)) inext = in 1847 | 1848 | end function variable_index 1849 | !******************************************************************************* 1850 | 1851 | !******************************************************************************* 1852 | !> 1853 | ! Remove Spaces from string, remember positions of characters in old string 1854 | 1855 | subroutine remove_spaces (str, ipos) 1856 | 1857 | implicit none 1858 | 1859 | character(len=*),intent(inout) :: str 1860 | integer,dimension(:),intent(inout) :: ipos 1861 | 1862 | integer :: k,lstr 1863 | 1864 | lstr = len_trim(str) 1865 | k = 1 1866 | do while (str(k:lstr) /= ' ') 1867 | if (str(k:k) == ' ') then 1868 | str(k:lstr) = str(k+1:lstr)//' ' ! move 1 character to left 1869 | ipos(k:lstr) = [ ipos(k+1:lstr), 0 ] ! move 1 element to left 1870 | k = k-1 1871 | end if 1872 | k = k+1 1873 | end do 1874 | 1875 | end subroutine remove_spaces 1876 | !******************************************************************************* 1877 | 1878 | !******************************************************************************* 1879 | !> 1880 | ! replace ALL appearances of character set `ca` in 1881 | ! string `str` by character set `cb` 1882 | 1883 | subroutine replace_string(ca,cb,str) 1884 | 1885 | implicit none 1886 | 1887 | character(len=*),intent(in) :: ca 1888 | character(len=len(ca)),intent(in) :: cb !! `len(ca)` must be `len(cb)` 1889 | character(len=*),intent(inout) :: str 1890 | 1891 | integer :: j,lca 1892 | 1893 | lca = len(ca) 1894 | do j=1,len_trim(str)-lca+1 1895 | if (str(j:j+lca-1) == ca) str(j:j+lca-1) = cb 1896 | end do 1897 | 1898 | end subroutine replace_string 1899 | !******************************************************************************* 1900 | 1901 | !******************************************************************************* 1902 | !> 1903 | ! Compile function string `f` into bytecode 1904 | ! 1905 | !@note This is not very efficient since it is parsing it twice 1906 | ! just to get the size of all the arrays. 1907 | 1908 | subroutine compile (me, f, var) 1909 | 1910 | implicit none 1911 | 1912 | class(fparser),intent(inout) :: me 1913 | character(len=*),intent(in) :: f !! function string 1914 | character(len=*),dimension(:),intent(in) :: var !! array with variable names 1915 | 1916 | integer :: istat !! allocation status flag 1917 | 1918 | me%bytecodesize = 0 1919 | me%immedsize = 0 1920 | me%stacksize = 0 1921 | me%stackptr = 0 1922 | 1923 | ! compile string to determine size: 1924 | call me%compile_substr (f,1,len_trim(f),var) 1925 | 1926 | allocate ( me%bytecode(me%bytecodesize), & 1927 | me%bytecode_ops(me%bytecodesize), & 1928 | me%immed(me%immedsize), & 1929 | me%stack(me%stacksize), & 1930 | stat = istat ) 1931 | 1932 | if (istat /= 0) then 1933 | call me%error_msg%add('*** Parser error: Memory allocation for byte code failed') 1934 | else 1935 | me%bytecodesize = 0 1936 | me%immedsize = 0 1937 | me%stacksize = 0 1938 | me%stackptr = 0 1939 | call me%compile_substr (f,1,len_trim(f),var) ! compile string into bytecode 1940 | end if 1941 | 1942 | end subroutine compile 1943 | !******************************************************************************* 1944 | 1945 | !******************************************************************************* 1946 | !> 1947 | ! Add compiled byte to bytecode 1948 | 1949 | subroutine add_compiled_byte (me, b, num_args) 1950 | 1951 | implicit none 1952 | 1953 | class(fparser),intent(inout) :: me 1954 | integer,intent(in) :: b !! value of byte to be added 1955 | integer, optional, intent(in) :: num_args 1956 | 1957 | integer :: args 1958 | 1959 | if (present(num_args)) then 1960 | args = num_args 1961 | else 1962 | ! The required_args parameter array is not indexed from 1. 1963 | if ( (b >= lbound(required_args, 1)) .and. (b <= ubound(required_args, 1)) ) then 1964 | args = required_args(b) 1965 | endif 1966 | endif 1967 | 1968 | me%bytecodesize = me%bytecodesize + 1 1969 | 1970 | if (allocated(me%bytecode)) then 1971 | 1972 | !integer: 1973 | me%bytecode(me%bytecodesize) = b 1974 | 1975 | !set the function pointer: 1976 | ! [this replaces the original code which used 1977 | ! a case statement during the evaluation] 1978 | select case (b) 1979 | case (cImmed); me%bytecode_ops(me%bytecodesize)%f => cimmed_func 1980 | case (cNeg); me%bytecode_ops(me%bytecodesize)%f => cneg_func 1981 | case (cAdd); me%bytecode_ops(me%bytecodesize)%f => cadd_func 1982 | case (cSub); me%bytecode_ops(me%bytecodesize)%f => csub_func 1983 | case (cMul); me%bytecode_ops(me%bytecodesize)%f => cmul_func 1984 | case (cDiv); me%bytecode_ops(me%bytecodesize)%f => cdiv_func 1985 | case (cPow); me%bytecode_ops(me%bytecodesize)%f => cpow_func 1986 | case (cabs); me%bytecode_ops(me%bytecodesize)%f => cabs_func 1987 | case (cExp); me%bytecode_ops(me%bytecodesize)%f => cexp_func 1988 | case (cLog10); me%bytecode_ops(me%bytecodesize)%f => clog10_func 1989 | case (cLog); me%bytecode_ops(me%bytecodesize)%f => clog_func 1990 | case (cSqrt); me%bytecode_ops(me%bytecodesize)%f => csqrt_func 1991 | case (cSinh); me%bytecode_ops(me%bytecodesize)%f => csinh_func 1992 | case (cCosh); me%bytecode_ops(me%bytecodesize)%f => ccosh_func 1993 | case (cTanh); me%bytecode_ops(me%bytecodesize)%f => ctanh_func 1994 | case (cSin); me%bytecode_ops(me%bytecodesize)%f => csin_func 1995 | case (cCos); me%bytecode_ops(me%bytecodesize)%f => ccos_func 1996 | case (cTan); me%bytecode_ops(me%bytecodesize)%f => ctan_func 1997 | case (cAsin); me%bytecode_ops(me%bytecodesize)%f => casin_func 1998 | case (cAcos); me%bytecode_ops(me%bytecodesize)%f => cacos_func 1999 | case (cAtan2); me%bytecode_ops(me%bytecodesize)%f => catan2_func 2000 | case (cAtan) 2001 | select case (args) 2002 | case (1); me%bytecode_ops(me%bytecodesize)%f => catan_func 2003 | case (2); me%bytecode_ops(me%bytecodesize)%f => catan2_func 2004 | end select 2005 | case (cPi); me%bytecode_ops(me%bytecodesize)%f => cPi_func 2006 | 2007 | case(cCeil); me%bytecode_ops(me%bytecodesize)%f => cceil_func 2008 | case(cFloor); me%bytecode_ops(me%bytecodesize)%f => cfloor_func 2009 | case(cGamma); me%bytecode_ops(me%bytecodesize)%f => cgamma_func 2010 | case(cHypot); me%bytecode_ops(me%bytecodesize)%f => chypot_func 2011 | case(cMax); me%bytecode_ops(me%bytecodesize)%f => cmax_func 2012 | case(cMin); me%bytecode_ops(me%bytecodesize)%f => cmin_func 2013 | case(cMod); me%bytecode_ops(me%bytecodesize)%f => cmod_func 2014 | case(cModulo); me%bytecode_ops(me%bytecodesize)%f => cmodulo_func 2015 | case(cSign); me%bytecode_ops(me%bytecodesize)%f => csign_func 2016 | 2017 | case (cIf); me%bytecode_ops(me%bytecodesize)%f => cif_func 2018 | case default; me%bytecode_ops(me%bytecodesize)%f => cdefault_func 2019 | end select 2020 | 2021 | end if 2022 | 2023 | end subroutine add_compiled_byte 2024 | !******************************************************************************* 2025 | 2026 | !******************************************************************************* 2027 | !> 2028 | ! return math item index, if item is real number, enter it into Comp-structure 2029 | 2030 | function mathitem_index (me, f, var) result (n) 2031 | 2032 | implicit none 2033 | 2034 | class(fparser),intent(inout) :: me 2035 | character(len=*),intent(in) :: f !! function substring 2036 | character(len=*),dimension(:),intent(in) :: var !! array with variable names 2037 | 2038 | integer :: n !! byte value of math item 2039 | 2040 | n = 0 2041 | if (len(f)==0) return ! error condition 2042 | 2043 | if (scan(f(1:1),'0123456789.') > 0) then ! check for begin of a number 2044 | me%immedsize = me%immedsize + 1 2045 | if (allocated(me%immed)) then 2046 | me%immed(me%immedsize) = string_to_real (f) 2047 | end if 2048 | n = cimmed 2049 | else ! check for a variable 2050 | n = variable_index (f, var) 2051 | if (n > 0) n = varbegin+n-1 2052 | end if 2053 | 2054 | end function mathitem_index 2055 | !******************************************************************************* 2056 | 2057 | !******************************************************************************* 2058 | !> 2059 | ! Check if function substring F(b:e) is completely enclosed by a pair of parenthesis 2060 | 2061 | function completely_enclosed (f, b, e) result (res) 2062 | 2063 | implicit none 2064 | 2065 | character (len=*), intent(in) :: f !! function substring 2066 | integer, intent(in) :: b,e !! first and last pos. of substring 2067 | logical :: res 2068 | 2069 | integer :: j,k 2070 | 2071 | res=.false. 2072 | if (b==0 .or. e==0) return 2073 | if (f(b:b) == '(' .and. f(e:e) == ')') then 2074 | k = 0 2075 | do j=b+1,e-1 2076 | if (f(j:j) == '(') then 2077 | k = k+1 2078 | elseif (f(j:j) == ')') then 2079 | k = k-1 2080 | end if 2081 | if (k < 0) exit 2082 | end do 2083 | if (k == 0) res=.true. ! all opened parenthesis closed 2084 | end if 2085 | 2086 | end function completely_enclosed 2087 | !******************************************************************************* 2088 | 2089 | !******************************************************************************* 2090 | !> 2091 | ! Compile i-th function string `f` into bytecode 2092 | 2093 | recursive subroutine compile_substr (me, f, b, e, var) 2094 | 2095 | implicit none 2096 | 2097 | class(fparser),intent(inout) :: me 2098 | character(len=*),intent(in) :: f !! function substring 2099 | integer,intent(in) :: b !! begin position substring 2100 | integer,intent(in) :: e !! end position substring 2101 | character(len=*),dimension(:),intent(in) :: var !! array with variable names 2102 | 2103 | integer :: n 2104 | integer :: b2,j,k,io 2105 | character (len=*),parameter :: calpha = 'abcdefghijklmnopqrstuvwxyz'// & 2106 | 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 2107 | 2108 | integer :: arg_pos(max_func_args) 2109 | integer :: num_args, iarg 2110 | 2111 | ! check for special cases of substring 2112 | if (f(b:b) == '+') then ! case 1: f(b:e) = '+...' 2113 | call compile_substr (me, f, b+1, e, var) 2114 | return 2115 | elseif (completely_enclosed (f, b, e)) then ! case 2: f(b:e) = '(...)' 2116 | call compile_substr (me, f, b+1, e-1, var) 2117 | return 2118 | elseif (scan(f(b:b),calpha) > 0) then 2119 | n = mathfunction_index (f(b:e), var) 2120 | if (n > 0) then 2121 | b2 = b+index(f(b:e),'(')-1 2122 | if (completely_enclosed(f, b2, e)) then ! case 3: f(b:e) = 'fcn(...)' 2123 | 2124 | ! Determine the number of function arguments. 2125 | call find_arg_positions (b2, f, num_args, arg_pos) 2126 | 2127 | if (num_args > 0) then 2128 | do iarg = 1, num_args 2129 | call compile_substr (me, f, b2+1, arg_pos(iarg), var) 2130 | if (iarg < num_args) then 2131 | me%stackptr = me%stackptr + 1 2132 | if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1 2133 | b2 = arg_pos(iarg) + 1 2134 | end if 2135 | end do 2136 | else 2137 | me%stackptr = me%stackptr + 1 2138 | if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1 2139 | end if 2140 | 2141 | call add_compiled_byte (me, n, num_args) 2142 | return 2143 | end if 2144 | end if 2145 | elseif (f(b:b) == '-') then 2146 | if (completely_enclosed (f, b+1, e)) then ! case 4: f(b:e) = '-(...)' 2147 | call compile_substr (me, f, b+2, e-1, var) 2148 | call add_compiled_byte (me, cneg) 2149 | return 2150 | elseif (scan(f(b+1:b+1),calpha) > 0) then 2151 | n = mathfunction_index (f(b+1:e), var) 2152 | if (n > 0) then 2153 | b2 = b+index(f(b+1:e),'(') 2154 | if (completely_enclosed(f, b2, e)) then ! case 5: f(b:e) = '-fcn(...)' 2155 | 2156 | ! Determine the number of function arguments. 2157 | call find_arg_positions (b2, f, num_args, arg_pos) 2158 | 2159 | if (num_args > 0) then 2160 | do iarg = 1, num_args 2161 | call compile_substr (me, f, b2+1, arg_pos(iarg), var) 2162 | if (iarg < num_args) then 2163 | me%stackptr = me%stackptr + 1 2164 | if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1 2165 | b2 = arg_pos(iarg) + 1 2166 | end if 2167 | end do 2168 | else 2169 | me%stackptr = me%stackptr + 1 2170 | if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1 2171 | end if 2172 | 2173 | call add_compiled_byte (me, n, num_args) 2174 | call add_compiled_byte (me, cneg) 2175 | return 2176 | end if 2177 | end if 2178 | end if 2179 | end if 2180 | 2181 | ! check for operator in substring: check only base level (k=0), exclude expr. in () 2182 | do io=cadd,cpow ! increasing priority +-*/^ 2183 | k = 0 2184 | do j=e,b,-1 2185 | if (f(j:j) == ')') then 2186 | k = k+1 2187 | elseif (f(j:j) == '(') then 2188 | k = k-1 2189 | end if 2190 | if (k == 0 .and. f(j:j) == operators(io) .and. is_binary_operator (j, f)) then 2191 | if (any(f(j:j) == operators(cmul:cpow)) .and. f(b:b) == '-') then ! case 6: f(b:e) = '-...op...' with op > - 2192 | call compile_substr (me, f, b+1, e, var) 2193 | call add_compiled_byte (me, cneg) 2194 | return 2195 | else ! case 7: f(b:e) = '...binop...' 2196 | call compile_substr (me, f, b, j-1, var) 2197 | call compile_substr (me, f, j+1, e, var) 2198 | call add_compiled_byte (me, operator_index(operators(io))) 2199 | me%stackptr = me%stackptr - 1 2200 | return 2201 | end if 2202 | end if 2203 | end do 2204 | end do 2205 | 2206 | ! check for remaining items, i.e. variables or explicit numbers 2207 | b2 = b 2208 | if (f(b:b) == '-') b2 = b2+1 2209 | n = mathitem_index(me, f(b2:e), var) 2210 | call add_compiled_byte (me, n) 2211 | me%stackptr = me%stackptr + 1 2212 | if (me%stackptr > me%stacksize) me%stacksize = me%stacksize + 1 2213 | if (b2 > b) call add_compiled_byte (me, cneg) 2214 | 2215 | end subroutine compile_substr 2216 | !******************************************************************************* 2217 | 2218 | !******************************************************************************* 2219 | !> 2220 | ! Check if operator `f(j:j)` in string `f` is binary operator. 2221 | ! 2222 | ! Special cases already covered elsewhere: (that is corrected in v1.1) 2223 | ! * operator character `f(j:j)` is first character of string (`j=1`) 2224 | 2225 | function is_binary_operator (j, f) result (res) 2226 | 2227 | implicit none 2228 | 2229 | integer,intent(in) :: j !! position of operator 2230 | character (len=*),intent(in) :: f !! string 2231 | logical :: res !! result 2232 | 2233 | integer :: k 2234 | logical :: dflag,pflag 2235 | 2236 | res=.true. 2237 | if (f(j:j) == '+' .or. f(j:j) == '-') then ! plus or minus sign: 2238 | if (j == 1) then ! - leading unary operator ? 2239 | res = .false. 2240 | elseif (scan(f(j-1:j-1),',+-*/^(') > 0) then ! - other unary operator ? (or comma from multi-arg functions) 2241 | res = .false. 2242 | elseif (scan(f(j+1:j+1),'0123456789') > 0 .and. & ! - in exponent of real number ? 2243 | scan(f(j-1:j-1),'eEdD') > 0) then 2244 | dflag=.false. 2245 | pflag=.false. 2246 | k = j-1 2247 | do while (k > 1) ! step to the left in mantissa 2248 | k = k-1 2249 | if (scan(f(k:k),'0123456789') > 0) then 2250 | dflag=.true. 2251 | elseif (f(k:k) == '.') then 2252 | if (pflag) then 2253 | exit ! * exit: 2nd appearance of '.' 2254 | else 2255 | pflag=.true. ! * mark 1st appearance of '.' 2256 | endif 2257 | else 2258 | exit ! * all other characters 2259 | end if 2260 | end do 2261 | if (dflag .and. (k == 1 .or. scan(f(k:k),',+-*/^(') > 0)) res = .false. ! need the comma here too ?? 2262 | end if 2263 | end if 2264 | 2265 | end function is_binary_operator 2266 | !******************************************************************************* 2267 | 2268 | !******************************************************************************* 2269 | !> 2270 | ! Get real number from string. 2271 | ! 2272 | ! Format: `[blanks][+|-][nnn][.nnn][e|E|d|D[+|-]nnn]` 2273 | 2274 | function string_to_real (str, ibegin, inext, error) result (res) 2275 | 2276 | implicit none 2277 | 2278 | real(wp) :: res !! real number 2279 | character (len=*), intent(in) :: str !! string 2280 | integer, optional, intent(out) :: ibegin !! start position of real number 2281 | integer, optional, intent(out) :: inext !! 1st character after real number 2282 | logical, optional, intent(out) :: error !! error flag 2283 | 2284 | integer :: ib,in,istat 2285 | logical :: Bflag !! True at begin of number in str 2286 | logical :: InMan !! True in mantissa of number 2287 | logical :: Pflag !! True after 1st '.' encountered 2288 | logical :: Eflag !! True at exponent identifier 'eEdD' 2289 | logical :: InExp !! True in exponent of number 2290 | logical :: DInMan !! True if at least 1 digit in mant. 2291 | logical :: DInExp !! True if at least 1 digit in exp. 2292 | logical :: err !! Local error flag 2293 | 2294 | Bflag=.true. 2295 | InMan=.false. 2296 | Pflag=.false. 2297 | Eflag=.false. 2298 | InExp=.false. 2299 | DInMan=.false. 2300 | DInExp=.false. 2301 | ib = 1 2302 | in = 1 2303 | do while (in <= len_trim(str)) 2304 | select case (str(in:in)) 2305 | case (' ') ! Only leading blanks permitted 2306 | ib = ib+1 2307 | if (InMan .or. Eflag .or. InExp) exit 2308 | case ('+','-') ! Permitted only 2309 | if (Bflag) then 2310 | InMan=.true.; Bflag=.false. ! - at beginning of mantissa 2311 | elseif (Eflag) then 2312 | InExp=.true.; Eflag=.false. ! - at beginning of exponent 2313 | else 2314 | exit ! - otherwise STOP 2315 | endif 2316 | case ('0':'9') ! Mark 2317 | if (Bflag) then 2318 | InMan=.true.; Bflag=.false. ! - beginning of mantissa 2319 | elseif (Eflag) then 2320 | InExp=.true.; Eflag=.false. ! - beginning of exponent 2321 | endif 2322 | if (InMan) DInMan=.true. ! Mantissa contains digit 2323 | if (InExp) DInExp=.true. ! Exponent contains digit 2324 | case ('.') 2325 | if (Bflag) then 2326 | Pflag=.true. ! - mark 1st appearance of '.' 2327 | InMan=.true.; Bflag=.false. ! mark beginning of mantissa 2328 | elseif (InMan .and..not.Pflag) then 2329 | Pflag=.true. ! - mark 1st appearance of '.' 2330 | else 2331 | exit ! - otherwise STOP 2332 | end if 2333 | case ('e','E','d','D') ! Permitted only 2334 | if (InMan) then 2335 | Eflag=.true.; InMan=.false. ! - following mantissa 2336 | else 2337 | exit ! - otherwise STOP 2338 | endif 2339 | case default 2340 | exit ! STOP at all other characters 2341 | end select 2342 | in = in+1 2343 | end do 2344 | err = (ib > in-1) .or. (.not.DInMan) .or. ((Eflag.or.InExp).and..not.DInExp) 2345 | if (err) then 2346 | res = zero 2347 | else 2348 | read(str(ib:in-1),*,iostat=istat) res 2349 | err = istat /= 0 2350 | end if 2351 | if (present(ibegin)) ibegin = ib 2352 | if (present(inext)) inext = in 2353 | if (present(error)) error = err 2354 | 2355 | end function string_to_real 2356 | !******************************************************************************* 2357 | 2358 | !******************************************************************************* 2359 | !> 2360 | ! Transform upper case letters in `str1` into 2361 | ! lower case letters, result is `str2`. 2362 | 2363 | pure elemental subroutine to_lowercase (str1, str2) 2364 | 2365 | implicit none 2366 | 2367 | character (len=*), intent(in) :: str1 2368 | character (len=*), intent(out) :: str2 2369 | 2370 | integer :: j,k 2371 | character(len=*), parameter :: lc = 'abcdefghijklmnopqrstuvwxyz' 2372 | character(len=*), parameter :: uc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 2373 | 2374 | str2 = str1 2375 | do j=1,len_trim(str1) 2376 | k = index(uc,str1(j:j)) 2377 | if (k > 0) str2(j:j) = lc(k:k) 2378 | end do 2379 | 2380 | end subroutine to_lowercase 2381 | !******************************************************************************* 2382 | 2383 | !******************************************************************************* 2384 | end module function_parser 2385 | !******************************************************************************* 2386 | --------------------------------------------------------------------------------