├── .gitignore ├── CMakeLists.txt ├── README.md ├── input ├── square.geo └── testConfig.cfg ├── pages ├── IO │ ├── config.md │ ├── index.md │ ├── matIO.md │ ├── mesh.md │ ├── netCDF.md │ └── vtkIO.md ├── Matrix │ ├── index.md │ ├── quaternion.md │ ├── solvers.md │ ├── sparse.md │ └── tensor.md ├── PlPlotLib │ ├── arguments.md │ ├── escapeCodes.md │ └── index.md ├── autoDiff.md ├── expression.md ├── fourier.md ├── index.md └── license.md ├── project.md ├── references ├── derivations.lyx └── splineFiniteDifference.py └── src ├── IO ├── config.f90 ├── matIO.f90 ├── mesh.f90 ├── netCDF.f90 ├── text.f90 └── vtkIO.f90 ├── array.f90 ├── autoDiff ├── autoDiff.f90 ├── autoDiffArray.f90 ├── autoDiffExponential.f90 ├── autoDiffOperator.f90 ├── autoDiffTrigonometric.f90 ├── autoDiffType.f90 ├── autoDiffZ.f90 ├── autoDiffZArray.f90 ├── autoDiffZExponential.f90 ├── autoDiffZOperator.f90 ├── autoDiffZTrigonometric.f90 └── autoDiffZType.f90 ├── constants.f90 ├── expression ├── expression.f90 ├── node.f90 ├── treeExponential.f90 ├── treeOperator.f90 ├── treeTrigonometric.f90 └── treeValue.f90 ├── fftw3.f90 ├── fourier.f90 ├── generate-unitsParameters.py ├── iterate.f90 ├── kinds.f90 ├── matrix ├── basicSolvers.f90 ├── basicSolversZ.f90 ├── quaternion.f90 ├── solvers.f90 ├── sparse.f90 ├── sparseZ.f90 └── tensor.f90 ├── optimize.f90 ├── plplotlib ├── animate.f90 ├── basic.f90 ├── examples.f90 ├── logo.f90 ├── plplotlib.f90 ├── plplotlib1D.f90 ├── plplotlib2D.f90 ├── plplotlib3D.f90 ├── plplotlibBase.f90 └── plplotlibFigure.f90 ├── spline.f90 ├── stats.f90 ├── test ├── testArray.f90 ├── testAutoDiff.f90 ├── testConfig.f90 ├── testConstants.f90 ├── testExpression.f90 ├── testFourier.f90 ├── testIterate.f90 ├── testKinds.f90 ├── testMatIO.f90 ├── testMesh.f90 ├── testNetCDF.f90 ├── testOptimize.f90 ├── testQuaternion.f90 ├── testSparse.f90 ├── testSpline.f90 ├── testStats.f90 ├── testTensor.f90 ├── testText.f90 ├── testTime.f90 ├── testUnits.f90 └── testVtkIO.f90 ├── time.f90 └── units.f90 /.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | pending/ 3 | 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ReadMe 2 | ====== 3 | 4 | This project contains a collection of commonly-used routines for use in developing simulations. 5 | 6 | The initial goals of this project are the following: 7 | 8 | * Sensible break-down of routines into modules 9 | * Full documentation with FORD 10 | * Reasonable testing with CTest 11 | * Reasonable revision control with Git 12 | -------------------------------------------------------------------------------- /input/square.geo: -------------------------------------------------------------------------------- 1 | // Gmsh 2 | 3 | Mesh.ElementOrder = 2; 4 | 5 | L = 1.0; 6 | N = 3.0; 7 | h = 2.0*L/N; 8 | 9 | Point(1) = {-L,-L, 0,h}; 10 | Point(2) = { L,-L, 0,h}; 11 | Point(3) = { L, L, 0,h}; 12 | Point(4) = {-L, L, 0,h}; 13 | 14 | Line(1) = {1,2}; 15 | Line(2) = {2,3}; 16 | Line(3) = {3,4}; 17 | Line(4) = {4,1}; 18 | 19 | Line Loop(5) = {1, 2, 3, 4}; 20 | Plane Surface(1) = {5}; 21 | 22 | Physical Surface("domain(1.0)::interior") = {1}; 23 | 24 | Physical Line("known( 1.0)::east") = {2}; 25 | Physical Line("known( 0.0)::west") = {4}; 26 | Physical Line("empty::north") = {3}; 27 | Physical Line("empty::south") = {1}; 28 | 29 | Physical Point("known( 0.0)::sw") = {1}; 30 | Physical Point("known( 1.0)::se") = {2}; 31 | Physical Point("known( 1.0)::ne") = {3}; 32 | Physical Point("known( 0.0)::nw") = {4}; 33 | -------------------------------------------------------------------------------- /input/testConfig.cfg: -------------------------------------------------------------------------------- 1 | logical = True 2 | integer = 1 3 | real = 1.0 4 | complex = (1.0,1.0) 5 | 6 | vector = [1.0,2.0,3.0] 7 | 8 | matrix = Matrix(2,2) 9 | [1.0,2.0] 10 | [3.0,4.0] 11 | 12 | string = 'one' 13 | 14 | [section] 15 | 16 | real = 1.0 17 | -------------------------------------------------------------------------------- /pages/IO/config.md: -------------------------------------------------------------------------------- 1 | title: Config Instructions 2 | -------------------------------------------------------------------------------- /pages/IO/index.md: -------------------------------------------------------------------------------- 1 | title: I/O Instructions 2 | -------------------------------------------------------------------------------- /pages/IO/matIO.md: -------------------------------------------------------------------------------- 1 | title: matIO Instructions 2 | -------------------------------------------------------------------------------- /pages/IO/mesh.md: -------------------------------------------------------------------------------- 1 | title: Mesh Instructions 2 | -------------------------------------------------------------------------------- /pages/IO/netCDF.md: -------------------------------------------------------------------------------- 1 | title: netCDF Instructions 2 | -------------------------------------------------------------------------------- /pages/IO/vtkIO.md: -------------------------------------------------------------------------------- 1 | title: vtkIO Instructions 2 | -------------------------------------------------------------------------------- /pages/Matrix/index.md: -------------------------------------------------------------------------------- 1 | title: Matrix Instructions 2 | -------------------------------------------------------------------------------- /pages/Matrix/quaternion.md: -------------------------------------------------------------------------------- 1 | title: Quaternion Instructions 2 | -------------------------------------------------------------------------------- /pages/Matrix/solvers.md: -------------------------------------------------------------------------------- 1 | title: Solvers Instructions 2 | -------------------------------------------------------------------------------- /pages/Matrix/sparse.md: -------------------------------------------------------------------------------- 1 | title: Sparse Instructions 2 | -------------------------------------------------------------------------------- /pages/Matrix/tensor.md: -------------------------------------------------------------------------------- 1 | title: Tensor Instructions 2 | -------------------------------------------------------------------------------- /pages/PlPlotLib/arguments.md: -------------------------------------------------------------------------------- 1 | title: PlPlotLib Common Arguments 2 | 3 | Common Arguments 4 | ---------------- 5 | 6 | A number of arguments are accepted by many routines in the PlPlotLib 7 | module due to their common applicability. To prevent duplication of 8 | effort, these arguments are documented here with the expectation that 9 | they behave in a consistent/expected manner for each of the routines 10 | that accept them. 11 | 12 | Deviations from these standard behaviors or routine-specific extensions 13 | (if any) can be found in the documentation for each routine. 14 | 15 | ### `color` 16 | 17 | The color of various plot components may be set using a `character` value, 18 | for example `color='red'`. Acceptable values include the following: 19 | 20 | * 'k', 'black' :: Black 21 | * 'w', 'white' :: White 22 | * 'r', 'red' :: Red 23 | * 'g', 'green' :: Green 24 | * 'b', 'blue' :: Blue 25 | * 'm', 'magenta' :: Magenta 26 | * 'y', 'yellow' :: Yellow 27 | * 'c', 'cyan' :: Cyan 28 | * 'fg' :: Foreground 29 | * 'bg' :: Background 30 | 31 | Additionally, the `character` value may contain an ascii decimal encoding of 32 | `real` number between zero and one. 33 | In this case, the color will be taken from the continuous colormap instead 34 | of the discrete indexed colors. For example: `color=' 0.534 '` This can 35 | easily be automated through the use of internal files. 36 | 37 | @note 38 | [[plplotlibFigure_mod:box]] 39 | [[plplotlibFigure_mod:labels]] 40 | [[plplotlibFigure_mod:ticks]] 41 | [[plplotlibFigure_mod:title]] 42 | [[plplotlibFigure_mod:xlabel]] 43 | [[plplotlibFigure_mod:xticks]] 44 | [[plplotlibFigure_mod:ylabel]] 45 | [[plplotlibFigure_mod:yticks]] 46 | 47 | ### `lineColor` 48 | 49 | A `character` value noting the color to use when painting lines. 50 | Accepted values are the following: 51 | 52 | * 'k', 'black' :: Black 53 | * 'w', 'white' :: White 54 | * 'r', 'red' :: Red 55 | * 'g', 'green' :: Green 56 | * 'b', 'blue' :: Blue 57 | * 'm', 'magenta' :: Magenta 58 | * 'y', 'yellow' :: Yellow 59 | * 'c', 'cyan' :: Cyan 60 | * 'fg' :: Foreground 61 | * 'bg' :: Background 62 | 63 | Additionally, the `character` value may contain an ascii decimal encoding of 64 | `real` number between zero and one. 65 | In this case, the color will be taken from the continuous colormap instead 66 | of the discrete indexed colors. For example: `lineColor=' 0.534 '` This can 67 | easily be automated through the use of internal files. 68 | 69 | @note 70 | [[plplotlib1D_mod:hist]] 71 | [[plplotlib1D_mod:bar]] 72 | [[plplotlib1D_mod:barh]] 73 | [[plplotlib1D_mod:plot]] 74 | [[plplotlib2D_mod:contour]] 75 | [[plplotlib2D_mod:quiver]] 76 | [[plplotlib3D_mod:plot3]] 77 | [[plplotlib3D_mod:wireframe]] 78 | 79 | ### `lineStyle` 80 | 81 | The style of lines can be changed through the `lineStyle` argument which takes 82 | a `character` value. Accepted values are the following: 83 | 84 | * '-' :: Solid line 85 | * '--' :: Dashed line 86 | * ':' :: Dotted line 87 | 88 | @note 89 | [[plplotlib1D_mod:plot]] 90 | [[plplotlib2D_mod:contour]] 91 | [[plplotlib2D_mod:quiver]] 92 | [[plplotlib3D_mod:plot3]] 93 | [[plplotlib3D_mod:surface]] 94 | 95 | ### `lineWidth` 96 | 97 | The width of lines used in an operation can often be set usin the `lineWidth` 98 | argument, with a `real` number multiple of the default line width. For example, 99 | `lineWidth=2.5_wp` will cause lines to be two and a half times thicker than 100 | normal. 101 | 102 | @note 103 | [[plplotlibFigure_mod:ticks]] 104 | [[plplotlibFigure_mod:xticks]] 105 | [[plplotlibFigure_mod:yticks]] 106 | [[plplotlib1D_mod:plot]] 107 | [[plplotlib1D_mod:fillBetween]] 108 | [[plplotlib1D_mod:fillBetweenx]] 109 | [[plplotlib1D_mod:hist]] 110 | [[plplotlib1D_mod:bar]] 111 | [[plplotlib1D_mod:barh]] 112 | [[plplotlib2D_mod:contour]] 113 | [[plplotlib2D_mod:quiver]] 114 | [[plplotlib3D_mod:plot3]] 115 | 116 | ### `markColor` 117 | 118 | A `character` value noting the color to use when painting markers or symbols. 119 | Accepted values are the following: 120 | 121 | * 'k', 'black' :: Black 122 | * 'w', 'white' :: White 123 | * 'r', 'red' :: Red 124 | * 'g', 'green' :: Green 125 | * 'b', 'blue' :: Blue 126 | * 'm', 'magenta' :: Magenta 127 | * 'y', 'yellow' :: Yellow 128 | * 'c', 'cyan' :: Cyan 129 | * 'fg' :: Foreground 130 | * 'bg' :: Background 131 | 132 | Unlike line colors, marks cannot use the continuous colormap and are thus 133 | restricted to the indexed colors. 134 | 135 | @note 136 | [[plplotlib1D_mod:plot]] 137 | [[plplotlib1D_mod:scatter]] 138 | [[plplotlib3D_mod:plot3]] 139 | 140 | ### `markStyle` 141 | 142 | * '+' :: Plus 143 | * 'x :: Times 144 | * '*' :: Star 145 | * '.' :: Point 146 | * 's' :: Square 147 | * '^' :: Up triangle 148 | * '<' :: Left triangle 149 | * 'v' :: Down triangle 150 | * '>' :: Right triangle 151 | 152 | @note 153 | [[plplotlib1D_mod:plot]] 154 | [[plplotlib1D_mod:scatter]] 155 | [[plplotlib3D_mod:plot3]] 156 | 157 | ### `markSize` 158 | 159 | The size of markers can be scaled using the `markSize` argument, which takes 160 | a `real` value multiple of the default maker size. For example, `markSize=1.5_wp` 161 | will scale up the markers by 50% from the default size. 162 | 163 | @note 164 | [[plplotlib1D_mod:plot]] 165 | [[plplotlib1D_mod:scatter]] 166 | [[plplotlib3D_mod:plot3]] 167 | -------------------------------------------------------------------------------- /pages/PlPlotLib/escapeCodes.md: -------------------------------------------------------------------------------- 1 | title: PlPlotLib Escape Codes 2 | 3 | Character Escape Codes 4 | ---------------------- 5 | 6 | Escape codes can be inserted into character input to the plotting 7 | routines in order to change the formatting of the text. 8 | The supported codes are listed below: 9 | 10 | + `#u`: move up to the superscript position (ended with #d) 11 | + `#d`: move down to subscript position (ended with #u) 12 | + `#b`: backspace (to allow overprinting) 13 | + `##`: number symbol 14 | + `#+`: toggle overline mode 15 | + `#-`: toggle underline mode 16 | + `#gx`: Greek letter corresponding to Roman letter x (see below) 17 | + `#fn`: switch to normal (sans-serif) font 18 | + `#fr`: switch to Roman (serif) font 19 | + `#fi`: switch to italic font 20 | + `#fs`: switch to script font 21 | 22 | When greek letters are inserted using the code '#gx', the replacements 23 | are made according to the following rules: 24 | 25 | |= ROMAN =|= GREEK =| |= roman =|= greek =| 26 | |:-:|:-:|-|:-:|:-:| 27 | | A | Α | | a | α | 28 | | B | Β | | b | β | 29 | | G | Γ | | g | γ | 30 | | D | Δ | | d | δ | 31 | | E | Ε | | e | ε | 32 | | Z | Ζ | | z | ζ | 33 | | Y | Η | | y | η | 34 | | H | Θ | | h | θ | 35 | | I | Ι | | i | ι | 36 | | K | Κ | | k | κ | 37 | | L | Λ | | l | λ | 38 | | M | Μ | | m | μ | 39 | | N | Ν | | n | ν | 40 | | C | Ξ | | c | ξ | 41 | | O | Ο | | o | ο | 42 | | P | Π | | p | π | 43 | | R | Ρ | | r | ρ | 44 | | S | Σ | | s | σ | 45 | | T | Τ | | t | τ | 46 | | U | Υ | | u | υ | 47 | | F | Φ | | f | φ | 48 | | X | Χ | | x | χ | 49 | | Q | Ψ | | q | ψ | 50 | | W | Ω | | w | ω | 51 | 52 | One obvious application of escape codes is the formatting of axis 53 | labels, where symbols are usually italic to match their usage in the 54 | text of the document. Eg: 55 | 56 | ~~~ 57 | :::fortran 58 | call labels('#fix#fn','#fiy#fn','#fiy=f#d0#u(x)#fn') 59 | ~~~ 60 | -------------------------------------------------------------------------------- /pages/PlPlotLib/index.md: -------------------------------------------------------------------------------- 1 | title: PlPlotLib Instructions 2 | 3 | PlPlotLib Module Usage 4 | ---------------------- 5 | 6 | Plotting using PlPLotLib involves several basic steps that must be taken 7 | for the process to succeed. For a single line plot, the steps taken are 8 | the following: 9 | 10 | 1. Initialize the library (call setup) 11 | 2. Create a figure (call figure) 12 | 3. Specify the subplot (call subplot) 13 | 4. Specify axis ranges (call xylim) 14 | 5. Plot the data (call plot) 15 | 6. Draw axis ticks and numeric labels (call ticks) 16 | 7. Label the axes and subplot (call labels) 17 | 18 | The same basic process is followed for all plot types. The most common 19 | variations from these step are the inclusion of more than one plot and 20 | the creation of a legend to distinguish between plots. 21 | 22 | *Example* 23 | ~~~ 24 | :::fortran 25 | {!src/plplotlib/basic.f90!} 26 | ~~~ 27 | 28 | ![basic-1.svg](|media|/basic-1.svg) 29 | 30 | Step Details 31 | ------------ 32 | 33 | Details about each step of the process are found below: 34 | 35 | ### `setup` 36 | 37 | The `setup` routine initializes the plplot library and must be the 38 | first call made to the module. The output device can be specified 39 | through `device`, while the size of the plots can be controlled through 40 | `figSize`. After setup, these values unfortunately cannot be changed 41 | during execution of the program. 42 | 43 | *Example* 44 | ~~~ 45 | :::fortran 46 | call setup(device='svgqt',figSize=[800,600]) 47 | ~~~ 48 | 49 | @note 50 | [[plplotlibBase_mod:setup]] 51 | 52 | ### `figure` 53 | 54 | The `figure` routine creates a new figure on which to place plots. Its 55 | size is defined at library setup and cannot be changed afterwards. 56 | There are no options to this routine, but it must be called to setup 57 | the window or file for output. 58 | 59 | *Example* 60 | ~~~ 61 | :::fortran 62 | call figure() 63 | ~~~ 64 | 65 | ### `subplot` 66 | 67 | After the creation of a figure, plots must be positioned on the output 68 | surface. The `subplot` routine handles this process by breaking the 69 | figure into rows and columns and selecting a cell in which to plot. 70 | 71 | Basic usage might appear as the following: 72 | 73 | ~~~ 74 | :::fortran 75 | call subplot(2,3,1) 76 | ~~~ 77 | 78 | The command splits the figure into two rows and three columns, as well 79 | as preparing the library to plot in the upper-left most of these cells. 80 | 81 | Additionally, the subplot routine can force a particular aspect ratio 82 | for the plotting region, which is useful if the horizontal and vertical 83 | axes share the same units and should be scaled equally. 84 | 85 | @note 86 | [[plplotlibFigure_mod:subplot]] 87 | 88 | ### `xylim` 89 | 90 | A call to `xylim` is used to set the ranges of the plotting region. Most 91 | often the routine `mixval` is used to get the needed boundary arrays to 92 | specify these ranges. 93 | 94 | The most commonly use form of this routine will appear close to the 95 | following: 96 | 97 | ~~~ 98 | :::fortran 99 | real(wp),dimension(:),allocatable::x,y 100 | ... 101 | call xylim(mixval(x),mixval(y)) 102 | ~~~ 103 | 104 | There are two other variants of this routine which set only the horizontal 105 | or vertical ranges of the plot. 106 | 107 | @note 108 | [[plplotlibFigure_mod:xylim]] 109 | [[plplotlibFigure_mod:xlim]] 110 | [[plplotlibFigure_mod:ylim]] 111 | 112 | ### `plot` 113 | 114 | The basic `plot` routine draws a line plot in the defined plotting area 115 | using the set ranges for each axis to scale the data from plot 116 | coordinates to world coordinates on the output device. It requires 117 | arrays of horizontal and vertical positions, commonly referred to as 118 | `x` and `y`. 119 | 120 | Basic usage might appear as the following: 121 | 122 | ~~~ 123 | :::fortran 124 | real(wp),dimension(:),allocatable::x,y 125 | ... 126 | call plot(x,y) 127 | ~~~ 128 | 129 | @note 130 | [[plplotlib1D_mod:plot]] 131 | 132 | ### `ticks` 133 | 134 | The `ticks` routine is used to draw tick lines and labels on the axes, and 135 | can control some aspects of this process. 136 | 137 | Basic usage requires no arguments: 138 | 139 | ~~~ 140 | :::fortran 141 | 142 | call ticks() 143 | ~~~ 144 | 145 | Additional routines exist to control the drawing of ticks on the horizontal 146 | and vertical axes separately. 147 | 148 | @note 149 | [[plplotlibFigure_mod:ticks]] 150 | [[plplotlibFigure_mod:xticks]] 151 | [[plplotlibFigure_mod:yticks]] 152 | 153 | ### `labels` 154 | 155 | Labels can be added to the axes as well as the top of the plot using the 156 | `labels` routine. The color of the labels may also be adjusted. 157 | 158 | *Example* 159 | ~~~ 160 | :::fortran 161 | call labels('x-Axis','y-Axis','Plot Title') 162 | ~~~ 163 | 164 | Additional routines exist to control the drawing of labels on the horizontal 165 | and vertical axes, and the plot title, separately. 166 | 167 | @note 168 | [[plplotlibFigure_mod:labels]] 169 | [[plplotlibFigure_mod:xlabel]] 170 | [[plplotlibFigure_mod:ylabel]] 171 | [[plplotlibFigure_mod:title]] 172 | -------------------------------------------------------------------------------- /pages/autoDiff.md: -------------------------------------------------------------------------------- 1 | title: AutoDiff Instructions 2 | -------------------------------------------------------------------------------- /pages/expression.md: -------------------------------------------------------------------------------- 1 | title: Expression Instructions 2 | -------------------------------------------------------------------------------- /pages/fourier.md: -------------------------------------------------------------------------------- 1 | title: Fourier Instructions 2 | -------------------------------------------------------------------------------- /pages/index.md: -------------------------------------------------------------------------------- 1 | title: Instructions 2 | -------------------------------------------------------------------------------- /pages/license.md: -------------------------------------------------------------------------------- 1 | title: License 2 | 3 | License 4 | ------- 5 | 6 | Copyright (c) 2016, Dr. Kyle S. Horne 7 | All rights reserved. 8 | 9 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 10 | 11 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 18 | -------------------------------------------------------------------------------- /project.md: -------------------------------------------------------------------------------- 1 | project: CommonModules 2 | summary: Common modules for using in other programs 3 | author: Kyle Horne 4 | email: kyle.horne@gmail.com 5 | src_dir: src 6 | src_dir: src-gen 7 | page_dir: pages 8 | media_dir: media 9 | output_dir: doc 10 | exclude: fftw3.f90 11 | source: true 12 | display: public 13 | display: private 14 | graph: true 15 | search: true 16 | favicon: logo-1.png 17 | 18 | This project contains numerous modules for use in other projects with the specific intent of speeding up development of new simulations. 19 | The various routines and types are grouped according to task or data type, depending on the module. 20 | 21 | @todo 22 | 23 | * Clean up the documentation of interfaces and their implementations 24 | * Add rigorous tests for new modules 25 | * Add ODE system solvers 26 | 27 | @endtodo 28 | -------------------------------------------------------------------------------- /references/derivations.lyx: -------------------------------------------------------------------------------- 1 | #LyX 2.2 created this file. For more info see http://www.lyx.org/ 2 | \lyxformat 508 3 | \begin_document 4 | \begin_header 5 | \save_transient_properties true 6 | \origin unavailable 7 | \textclass article 8 | \use_default_options true 9 | \maintain_unincluded_children false 10 | \language english 11 | \language_package default 12 | \inputencoding auto 13 | \fontencoding global 14 | \font_roman "default" "default" 15 | \font_sans "default" "default" 16 | \font_typewriter "default" "default" 17 | \font_math "auto" "auto" 18 | \font_default_family default 19 | \use_non_tex_fonts false 20 | \font_sc false 21 | \font_osf false 22 | \font_sf_scale 100 100 23 | \font_tt_scale 100 100 24 | \graphics default 25 | \default_output_format default 26 | \output_sync 0 27 | \bibtex_command default 28 | \index_command default 29 | \paperfontsize default 30 | \use_hyperref false 31 | \papersize default 32 | \use_geometry false 33 | \use_package amsmath 1 34 | \use_package amssymb 1 35 | \use_package cancel 1 36 | \use_package esint 1 37 | \use_package mathdots 1 38 | \use_package mathtools 1 39 | \use_package mhchem 1 40 | \use_package stackrel 1 41 | \use_package stmaryrd 1 42 | \use_package undertilde 1 43 | \cite_engine basic 44 | \cite_engine_type default 45 | \biblio_style plain 46 | \use_bibtopic false 47 | \use_indices false 48 | \paperorientation portrait 49 | \suppress_date false 50 | \justification true 51 | \use_refstyle 1 52 | \index Index 53 | \shortcut idx 54 | \color #008000 55 | \end_index 56 | \secnumdepth 3 57 | \tocdepth 3 58 | \paragraph_separation indent 59 | \paragraph_indentation default 60 | \quotes_language english 61 | \papercolumns 1 62 | \papersides 1 63 | \paperpagestyle default 64 | \tracking_changes false 65 | \output_changes false 66 | \html_math_output 0 67 | \html_css_as_file 0 68 | \html_be_strict false 69 | \end_header 70 | 71 | \begin_body 72 | 73 | \begin_layout Section 74 | spline_mod 75 | \end_layout 76 | 77 | \begin_layout Itemize 78 | Finite difference 79 | \end_layout 80 | 81 | \begin_deeper 82 | \begin_layout Standard 83 | \begin_inset Formula 84 | \begin{align*} 85 | \left[A\right]\left\{ x\right\} & =\left\{ b\right\} \\ 86 | \left[A\right] & =\begin{bmatrix}1 & 1 & 1\\ 87 | -{\Delta t}_{-} & 0 & {\Delta t}_{+}\\ 88 | {\Delta t}_{-}^{2} & 0 & {\Delta t}_{+}^{2} 89 | \end{bmatrix}\\ 90 | \left\{ x\right\} & =\begin{Bmatrix}a\\ 91 | b\\ 92 | c 93 | \end{Bmatrix}\\ 94 | \left\{ b\right\} & =\begin{Bmatrix}0\\ 95 | 1\\ 96 | 0 97 | \end{Bmatrix}\\ 98 | {\Delta t}_{-} & =t_{k}-t_{k-1}\\ 99 | {\Delta t}_{+} & =t_{k+1}-t_{k}\\ 100 | \begin{Bmatrix}a\\ 101 | b\\ 102 | c 103 | \end{Bmatrix} & =\begin{Bmatrix}-\frac{{\Delta t}_{-}}{{\Delta t}_{+}}\left({\Delta t}_{-}+{\Delta t}_{+}\right)^{-1}\\ 104 | \frac{{\Delta t}_{-}-{\Delta t}_{+}}{{\Delta t}_{-}\times{\Delta t}_{+}}\\ 105 | \frac{{\Delta t}_{+}}{{\Delta t}_{-}}\left({\Delta t}_{-}+{\Delta t}_{+}\right)^{-1} 106 | \end{Bmatrix}\\ 107 | \frac{\partial\phi}{\partial t} & \approx a\phi_{k-1}+b\phi_{k}+c\phi_{k+1}+O\left({\Delta t}^{2}\right) 108 | \end{align*} 109 | 110 | \end_inset 111 | 112 | 113 | \end_layout 114 | 115 | \end_deeper 116 | \begin_layout Itemize 117 | Conventional 118 | \end_layout 119 | 120 | \begin_deeper 121 | \begin_layout Standard 122 | \begin_inset Formula 123 | \begin{align*} 124 | p\left(x\right) & =h_{00}\left(t\right)p_{k}+h_{10}\left(t\right)Lm_{k}+h_{01}\left(t\right)p_{k+1}+h_{11}\left(t\right)Lm_{k+1}\\ 125 | L & =x_{k+1}-x_{k}\\ 126 | t & =\frac{x-x_{k}}{x_{k+1}-x_{k}}=\frac{x-x_{k}}{L}\\ 127 | \frac{\partial t}{\partial x} & =\frac{1}{x_{k+1}-x_{k}}=\frac{1}{L}\\ 128 | m_{k} & =\left.\frac{\partial P}{\partial x}\right|_{x=x_{k}}\\ 129 | p_{k} & =P\left(x_{k}\right)\\ 130 | \frac{\partial^{2}p}{{\partial x}^{2}} & =\frac{\partial^{2}h_{00}}{{\partial t}^{2}}\frac{p_{k}}{L^{2}}+\frac{\partial^{2}h_{10}}{{\partial t}^{2}}\frac{m_{k}}{L}+\frac{\partial^{2}h_{01}}{{\partial t}^{2}}\frac{p_{k+1}}{L^{2}}+\frac{\partial^{2}h_{11}}{{\partial t}^{2}}\frac{m_{k+1}}{L}\\ 131 | \left(\left.\frac{\partial^{2}p}{{\partial x}^{2}}\right|_{t=1}\right)_{k-1} & =\left(\left.\frac{\partial^{2}p}{{\partial x}^{2}}\right|_{t=0}\right)_{k}\\ 132 | \left(\left.\frac{\partial^{2}p}{{\partial x}^{2}}\right|_{t=0}\right)_{k=1} & =0\\ 133 | \left(\left.\frac{\partial^{2}p}{{\partial x}^{2}}\right|_{t=1}\right)_{k=N} & =0 134 | \end{align*} 135 | 136 | \end_inset 137 | 138 | 139 | \end_layout 140 | 141 | \begin_layout Standard 142 | \begin_inset Formula 143 | \begin{align*} 144 | \begin{bmatrix}\frac{1}{L_{-}} & \frac{2}{L_{-}}+\frac{2}{L_{+}} & \frac{1}{L_{+}}\end{bmatrix}\begin{Bmatrix}m_{k-1}\\ 145 | m_{k}\\ 146 | m_{k+1} 147 | \end{Bmatrix} & =\begin{bmatrix}-\frac{3}{L_{-}^{2}} & \frac{3}{L_{-}^{2}}-\frac{3}{L_{+}^{2}} & \frac{3}{L_{+}^{2}}\end{bmatrix}\begin{Bmatrix}p_{k-1}\\ 148 | p_{k}\\ 149 | p_{k+1} 150 | \end{Bmatrix}\\ 151 | L_{-} & =x_{k}-x_{k-1}\\ 152 | L_{+} & =x_{k+1}-x_{k}\\ 153 | \begin{bmatrix}\frac{2}{L} & \frac{1}{L}\end{bmatrix}\begin{Bmatrix}m_{1}\\ 154 | m_{2} 155 | \end{Bmatrix} & =\begin{bmatrix}-\frac{3}{L^{2}} & \frac{3}{L^{2}}\end{bmatrix}\begin{Bmatrix}p_{1}\\ 156 | p_{2} 157 | \end{Bmatrix}\\ 158 | \begin{bmatrix}\frac{1}{L} & \frac{2}{L}\end{bmatrix}\begin{Bmatrix}m_{N-1}\\ 159 | m_{N} 160 | \end{Bmatrix} & =\begin{bmatrix}-\frac{3}{L^{2}} & \frac{3}{L^{2}}\end{bmatrix}\begin{Bmatrix}p_{N-1}\\ 161 | p_{N} 162 | \end{Bmatrix} 163 | \end{align*} 164 | 165 | \end_inset 166 | 167 | 168 | \end_layout 169 | 170 | \end_deeper 171 | \end_body 172 | \end_document 173 | -------------------------------------------------------------------------------- /references/splineFiniteDifference.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | from sympy import * 4 | 5 | a,b,c = symbols('a b c') 6 | dtm,dtp = symbols('dt_+ dt_-') 7 | 8 | A = Matrix( [ 9 | [ 1 , 1 , 1 ], 10 | [ -dtm , 0 , dtp ], 11 | [ dtm**2 , 0 , dtp**2 ] 12 | ] ) 13 | 14 | b = Matrix( [ 15 | [0], 16 | [1], 17 | [0] 18 | ] ) 19 | 20 | x = factor( A**(-1)*b ) 21 | 22 | pprint(x) 23 | -------------------------------------------------------------------------------- /src/IO/matIO.f90: -------------------------------------------------------------------------------- 1 | module matIO_mod 2 | !! Module to write MATLAB's mat file (version 4 only) 3 | !! 4 | !! @todo 5 | !! Document routines 6 | use iso_c_binding 7 | implicit none 8 | private 9 | 10 | !==============! 11 | != Interfaces =! 12 | !==============! 13 | 14 | interface v2m 15 | !! Convert a vector into a matrix 16 | module procedure v2m_i2 17 | module procedure v2m_i4 18 | module procedure v2m_r4 19 | module procedure v2m_r8 20 | module procedure v2m_z4 21 | module procedure v2m_z8 22 | end interface 23 | 24 | interface writeMat 25 | !! Write a matrix into a file 26 | module procedure writeMat_i2 27 | module procedure writeMat_i4 28 | module procedure writeMat_r4 29 | module procedure writeMat_r8 30 | module procedure writeMat_z4 31 | module procedure writeMat_z8 32 | end interface 33 | 34 | !===========! 35 | != Exports =! 36 | !===========! 37 | 38 | public::v2m 39 | public::writeMat 40 | 41 | contains 42 | 43 | function v2m_i2(v) result(o) 44 | integer(c_int16_t),dimension(:),intent(in)::v 45 | integer(c_int16_t),dimension(size(v),1)::o 46 | 47 | o(:,1) = v(:) 48 | end function v2m_i2 49 | 50 | function v2m_i4(v) result(o) 51 | integer(c_int32_t),dimension(:),intent(in)::v 52 | integer(c_int32_t),dimension(size(v),1)::o 53 | 54 | o(:,1) = v(:) 55 | end function v2m_i4 56 | 57 | function v2m_r4(v) result(o) 58 | real(c_float),dimension(:),intent(in)::v 59 | real(c_float),dimension(size(v),1)::o 60 | 61 | o(:,1) = v(:) 62 | end function v2m_r4 63 | 64 | function v2m_r8(v) result(o) 65 | real(c_double),dimension(:),intent(in)::v 66 | real(c_double),dimension(size(v),1)::o 67 | 68 | o(:,1) = v(:) 69 | end function v2m_r8 70 | 71 | function v2m_z4(v) result(o) 72 | complex(c_float_complex),dimension(:),intent(in)::v 73 | complex(c_float_complex),dimension(size(v),1)::o 74 | 75 | o(:,1) = v(:) 76 | end function v2m_z4 77 | 78 | function v2m_z8(v) result(o) 79 | complex(c_double_complex),dimension(:),intent(in)::v 80 | complex(c_double_complex),dimension(size(v),1)::o 81 | 82 | o(:,1) = v(:) 83 | end function v2m_z8 84 | 85 | subroutine writeMat_i2(fn,an,A,new) 86 | character(*),intent(in)::fn 87 | character(*),intent(in)::an 88 | integer(c_int16_t),dimension(:,:),intent(in)::A 89 | logical,intent(in),optional::new 90 | 91 | integer(c_int32_t),dimension(5)::header 92 | logical::over 93 | integer::u 94 | 95 | header(1) = 0030 96 | header(2) = size(A,1) 97 | header(3) = size(A,2) 98 | header(4) = 0 99 | header(5) = len(an)+1 100 | 101 | if(present(new)) then 102 | over = new 103 | else 104 | over = .false. 105 | end if 106 | 107 | if(over) then 108 | open(file=fn,access='stream',form='unformatted',newunit=u,status='replace') 109 | else 110 | open(file=fn,access='stream',form='unformatted',newunit=u,status='old',position='append') 111 | end if 112 | 113 | write(u) header 114 | write(u) an,C_NULL_CHAR 115 | write(u) A 116 | 117 | close(u) 118 | end subroutine writeMat_i2 119 | 120 | subroutine writeMat_i4(fn,an,A,new) 121 | character(*),intent(in)::fn 122 | character(*),intent(in)::an 123 | integer(c_int32_t),dimension(:,:),intent(in)::A 124 | logical,intent(in),optional::new 125 | 126 | integer(c_int32_t),dimension(5)::header 127 | logical::over 128 | integer::u 129 | 130 | header(1) = 0020 131 | header(2) = size(A,1) 132 | header(3) = size(A,2) 133 | header(4) = 0 134 | header(5) = len(an)+1 135 | 136 | if(present(new)) then 137 | over = new 138 | else 139 | over = .false. 140 | end if 141 | 142 | if(over) then 143 | open(file=fn,access='stream',form='unformatted',newunit=u,status='replace') 144 | else 145 | open(file=fn,access='stream',form='unformatted',newunit=u,status='old',position='append') 146 | end if 147 | 148 | write(u) header 149 | write(u) an,C_NULL_CHAR 150 | write(u) A 151 | 152 | close(u) 153 | end subroutine writeMat_i4 154 | 155 | subroutine writeMat_r4(fn,an,A,new) 156 | character(*),intent(in)::fn 157 | character(*),intent(in)::an 158 | real(c_float),dimension(:,:),intent(in)::A 159 | logical,intent(in),optional::new 160 | 161 | integer(c_int32_t),dimension(5)::header 162 | logical::over 163 | integer::u 164 | 165 | header(1) = 0010 166 | header(2) = size(A,1) 167 | header(3) = size(A,2) 168 | header(4) = 0 169 | header(5) = len(an)+1 170 | 171 | if(present(new)) then 172 | over = new 173 | else 174 | over = .false. 175 | end if 176 | 177 | if(over) then 178 | open(file=fn,access='stream',form='unformatted',newunit=u,status='replace') 179 | else 180 | open(file=fn,access='stream',form='unformatted',newunit=u,status='old',position='append') 181 | end if 182 | 183 | write(u) header 184 | write(u) an,C_NULL_CHAR 185 | write(u) A 186 | 187 | close(u) 188 | end subroutine writeMat_r4 189 | 190 | subroutine writeMat_r8(fn,an,A,new) 191 | character(*),intent(in)::fn 192 | character(*),intent(in)::an 193 | real(c_double),dimension(:,:),intent(in)::A 194 | logical,intent(in),optional::new 195 | 196 | integer(c_int32_t),dimension(5)::header 197 | logical::over 198 | integer::u 199 | 200 | header(1) = 0000 201 | header(2) = size(A,1) 202 | header(3) = size(A,2) 203 | header(4) = 0 204 | header(5) = len(an)+1 205 | 206 | if(present(new)) then 207 | over = new 208 | else 209 | over = .false. 210 | end if 211 | 212 | if(over) then 213 | open(file=fn,access='stream',form='unformatted',newunit=u,status='replace') 214 | else 215 | open(file=fn,access='stream',form='unformatted',newunit=u,status='old',position='append') 216 | end if 217 | 218 | write(u) header 219 | write(u) an,C_NULL_CHAR 220 | write(u) A 221 | 222 | close(u) 223 | end subroutine writeMat_r8 224 | 225 | subroutine writeMat_z4(fn,an,A,new) 226 | character(*),intent(in)::fn 227 | character(*),intent(in)::an 228 | complex(c_float_complex),dimension(:,:),intent(in)::A 229 | logical,intent(in),optional::new 230 | 231 | integer(c_int32_t),dimension(5)::header 232 | logical::over 233 | integer::u 234 | 235 | header(1) = 0010 236 | header(2) = size(A,1) 237 | header(3) = size(A,2) 238 | header(4) = 1 239 | header(5) = len(an)+1 240 | 241 | if(present(new)) then 242 | over = new 243 | else 244 | over = .false. 245 | end if 246 | 247 | if(over) then 248 | open(file=fn,access='stream',form='unformatted',newunit=u,status='replace') 249 | else 250 | open(file=fn,access='stream',form='unformatted',newunit=u,status='old',position='append') 251 | end if 252 | 253 | write(u) header 254 | write(u) an,C_NULL_CHAR 255 | write(u) real(A) 256 | write(u) imag(A) 257 | 258 | close(u) 259 | end subroutine writeMat_z4 260 | 261 | subroutine writeMat_z8(fn,an,A,new) 262 | character(*),intent(in)::fn 263 | character(*),intent(in)::an 264 | complex(c_double_complex),dimension(:,:),intent(in)::A 265 | logical,intent(in),optional::new 266 | 267 | integer(c_int32_t),dimension(5)::header 268 | logical::over 269 | integer::u 270 | 271 | header(1) = 0000 272 | header(2) = size(A,1) 273 | header(3) = size(A,2) 274 | header(4) = 1 275 | header(5) = len(an)+1 276 | 277 | if(present(new)) then 278 | over = new 279 | else 280 | over = .false. 281 | end if 282 | 283 | if(over) then 284 | open(file=fn,access='stream',form='unformatted',newunit=u,status='replace') 285 | else 286 | open(file=fn,access='stream',form='unformatted',newunit=u,status='old',position='append') 287 | end if 288 | 289 | write(u) header 290 | write(u) an,C_NULL_CHAR 291 | write(u) real(A) 292 | write(u) imag(A) 293 | 294 | close(u) 295 | end subroutine writeMat_z8 296 | 297 | end module matIO_mod 298 | -------------------------------------------------------------------------------- /src/IO/text.f90: -------------------------------------------------------------------------------- 1 | module text_mod 2 | !! Text processing module 3 | use iso_fortran_env 4 | use time_mod 5 | implicit none 6 | private 7 | 8 | !==============! 9 | != Parameters =! 10 | !==============! 11 | 12 | integer,parameter::stdin = INPUT_UNIT 13 | !! Standard input unit 14 | integer,parameter::stdout = OUTPUT_UNIT 15 | !! Standard output unit 16 | integer,parameter::stderr = ERROR_UNIT 17 | !! Standard error unit 18 | 19 | integer,parameter::strLong = 128 20 | !! Length for long characters 21 | integer,parameter::strShort = 32 22 | !! Length for short characters 23 | 24 | character(7),parameter::fmtLong = '(1A128)' 25 | !! Format for long characters 26 | character(6),parameter::fmtShort = '(1A32)' 27 | !! Format for short characters 28 | 29 | !===========! 30 | != Exports =! 31 | !===========! 32 | 33 | public::stdin 34 | public::stdout 35 | public::stderr 36 | 37 | public::strLong 38 | public::strShort 39 | 40 | public::fmtLong 41 | public::fmtShort 42 | 43 | public::removeSpaces 44 | 45 | public::startsWith 46 | public::endsWith 47 | 48 | public::intToChar 49 | public::realToChar 50 | public::realToTime 51 | 52 | public::charToArray 53 | public::arrayToChar 54 | 55 | public::colorize 56 | public::colorMap 57 | 58 | public::showProgress 59 | 60 | ! Kinds 61 | public::wp 62 | 63 | contains 64 | 65 | pure function removeSpaces(s) result(o) 66 | !! Remove all spaces from a string 67 | character(*),intent(in)::s 68 | !! String to remove spaces from 69 | character(:),allocatable::o 70 | !! String without spaces 71 | 72 | integer::sc,i,k 73 | 74 | sc = 0 75 | do k=1,len(s) 76 | if( s(k:k)==' ' ) sc = sc+1 77 | end do 78 | 79 | o = repeat(' ',len(s)-sc) 80 | i = 1 81 | do k=1,len(s) 82 | if( s(k:k)/=' ' ) then 83 | o(i:i) = s(k:k) 84 | i = i+1 85 | end if 86 | end do 87 | end function removeSpaces 88 | 89 | pure function startsWith(text,str) result(o) 90 | !! Test if text starts with str 91 | character(*),intent(in)::text 92 | !! Text to search 93 | character(*),intent(in)::str 94 | !! String to look for 95 | logical::o 96 | integer::k 97 | 98 | if(len(str)==0) then 99 | o = .true. 100 | else if(len(text)==0) then 101 | o = .false. 102 | else 103 | k = len(str) 104 | o = text(1:k)==str 105 | end if 106 | 107 | end function startsWith 108 | 109 | pure function endsWith(text,str) result(o) 110 | !! Test if text ends with str 111 | character(*),intent(in)::text 112 | !! Text to search 113 | character(*),intent(in)::str 114 | !! String to look for 115 | logical::o 116 | integer::k 117 | 118 | if(len(str)==0) then 119 | o = .true. 120 | else if(len(text)==0) then 121 | o = .false. 122 | else 123 | k = len(text) 124 | o = text(k-len(str)+1:k)==str 125 | end if 126 | 127 | end function endsWith 128 | 129 | pure function intToChar(a,f,l) result(o) 130 | !! Create a string from an integer 131 | integer,intent(in)::a 132 | !! Integer value to convert 133 | character(*),optional,intent(in)::f 134 | !! Format to use 135 | integer,optional,intent(in)::l 136 | !! Final length of string 137 | character(:),allocatable::o 138 | 139 | character(128)::buf 140 | 141 | if(present(l)) then 142 | allocate(character(l)::o) 143 | if(present(f)) then 144 | write(o,'('//f//')') a 145 | else 146 | write(o,*) a 147 | end if 148 | o = adjustl(o) 149 | else 150 | if(present(f)) then 151 | write(buf,'('//f//')') a 152 | else 153 | write(buf,*) a 154 | end if 155 | o = trim(adjustl(buf)) 156 | end if 157 | end function intToChar 158 | 159 | pure function realToChar(a,f,l) result(o) 160 | !! Create a string from a real number 161 | real(wp),intent(in)::a 162 | !! Real value to convert 163 | character(*),optional,intent(in)::f 164 | !! Format to use 165 | integer,optional,intent(in)::l 166 | !! Final string length 167 | character(:),allocatable::o 168 | 169 | character(128)::buf 170 | 171 | if(present(l)) then 172 | allocate(character(l)::o) 173 | if(present(f)) then 174 | write(o,'('//f//')') a 175 | else 176 | write(o,*) a 177 | end if 178 | o = adjustl(o) 179 | else 180 | if(present(f)) then 181 | write(buf,'('//f//')') a 182 | else 183 | write(buf,*) a 184 | end if 185 | o = trim(adjustl(buf)) 186 | end if 187 | end function realToChar 188 | 189 | pure function realToTime(a) result(o) 190 | !! Convert a real number to a string 191 | real(wp),intent(in)::a 192 | !! Time span in seconds 193 | character(:),allocatable::o 194 | 195 | integer::d,r,h,m,s,t 196 | character(:),allocatable::tc 197 | 198 | r = floor(a) 199 | 200 | d = r/(3600*24) 201 | r = mod(r,3600*24) 202 | 203 | h = r/3600 204 | r = mod(r,3600) 205 | 206 | m = r/60 207 | r = mod(r,60) 208 | 209 | s = r 210 | 211 | o = '' 212 | if(d>0) o = o//intToChar(d)//'d ' 213 | if(h>0.or.d>0) o = o//intToChar(h)//'h ' 214 | if(m>0.or.h>0.or.d>0) o = o//intToChar(m)//'m ' 215 | o = o//intToChar(s) 216 | 217 | if(d==0 .and. h==0 .and. m==0) then 218 | t = floor(1000.0_wp*(a-real(s,wp))) 219 | tc = intToChar(t) 220 | tc = repeat('0',3-len(tc))//tc 221 | o = o//'.'//tc 222 | end if 223 | 224 | o = o//'s' 225 | end function realToTime 226 | 227 | pure function charToArray(c) result(o) 228 | !! Convert a character into an array of character(1) 229 | character(*),intent(in)::c 230 | !! Character to convert 231 | character(1),dimension(:),allocatable::o 232 | !! New array of character(1) 233 | 234 | integer::k 235 | 236 | o = [character(1)::( c(k:k) , k=1,len(c) )] 237 | end function charToArray 238 | 239 | pure function arrayToChar(a) result(o) 240 | !! Convert an array of character(1) into a character 241 | character(1),dimension(:),intent(in)::a 242 | !! Array to convert 243 | character(:),allocatable::o 244 | !! New character 245 | 246 | integer::k 247 | 248 | allocate(character( size(a) )::o) 249 | do k=1,size(a) 250 | o(k:k) = a(k) 251 | end do 252 | end function arrayToChar 253 | 254 | function colorize(s,c) result(o) 255 | !! Bracket a string with text to change its color on a terminal 256 | character(*),intent(in)::s 257 | !! String to colorize 258 | integer,dimension(3),intent(in)::c ! c in [0,5] 259 | !! Color to use in [r,g,b] format, where \(r,b,g \in [0,5]\) 260 | character(:),allocatable::o 261 | 262 | character(1),parameter::CR = achar(13) 263 | character(1),parameter::ESC = achar(27) 264 | character(3),parameter::post = '[0m' 265 | 266 | character(:),allocatable::pre 267 | 268 | pre = ESC//'[38;5;'//intToChar(36*c(1)+6*c(2)+c(3)+16)//'m' 269 | o = trim(pre)//s//ESC//post 270 | end function colorize 271 | 272 | subroutine showProgress(m,p,ml) 273 | !! Create a progress bar through successive calls 274 | character(*),intent(in)::m 275 | !! Message to display 276 | real(wp),intent(in)::p 277 | !! Progress fraction \(p\in[0,1]\) 278 | !! 0 = start progress 279 | !! 1 = complete progress 280 | integer,intent(in),optional::ml 281 | !! Message reserve length (used to align long messages) 282 | 283 | real(wp)::r 284 | real(wp),save::po 285 | real(wp),save::tStart 286 | real(wp)::tNow 287 | integer::mld 288 | integer::N,k 289 | 290 | N = 40 291 | mld = 40 292 | if(present(ml)) mld = ml 293 | 294 | if(p<=0.0_wp) then 295 | po = p 296 | tStart = wallTime() 297 | else if(p-po<=0.005 .and. p<1.0_wp) then 298 | return 299 | else 300 | po = p 301 | end if 302 | tNow = wallTime() 303 | 304 | write(stdout,'(1A)',advance='no') achar(13)//colorize(m//repeat(' ',mld-len(m))//' [',[5,5,0]) 305 | do k=1,N 306 | r = real(k-1,wp)/real(N-1,wp) 307 | if(r<=p) then 308 | write(stdout,'(1A)',advance='no') colorize('=',colorMap(r,[0.0_wp,1.0_wp])) 309 | else 310 | write(stdout,'(1A)',advance='no') colorize(' ',[0,0,0]) 311 | end if 312 | end do 313 | write(stdout,'(1A,1A,1X,1A,1A,1A,1A,1A,1A)',advance='no') colorize('] ',[5,5,0]), & 314 | & colorize(realToChar(100.0_wp*p,'1F5.1'),colorMap(p,[0.0_wp,1.0_wp])), & 315 | & colorize('%',[5,5,0]), colorize(' (',[5,5,0]), realToTime(tNow-tStart), & 316 | & colorize(' / ',[5,5,0]), realToTime( (tNow-tStart)/(p+0.0001_wp) ), colorize(')',[5,5,0]) 317 | if(p>=1.0_wp) write(stdout,'(1A)') repeat(' ',10) 318 | flush(stdout) 319 | end subroutine showProgress 320 | 321 | function colorMap(v,r) result(c) 322 | !! Return the color code for colorize based on the coolwarm color map 323 | real(wp),intent(in)::v 324 | !! Value to map 325 | real(wp),dimension(2),intent(in)::r 326 | !! Range over which to scale the colors 327 | integer,dimension(3)::c 328 | 329 | integer::s 330 | 331 | if(v j j>=i 290 | type(ad_t),dimension(:,:),intent(in)::A 291 | type(ad_t),dimension(:,:),allocatable,intent(inout):: LU 292 | integer,dimension(:),allocatable,intent(inout)::p 293 | integer::N,j,i,m 294 | 295 | LU = A 296 | 297 | N = size(A,1) 298 | p = [( i , i=1,N )] 299 | do i=1,N-1 300 | m = maxloc( abs( LU(p(i:),i) ) , 1 ) + (i-1) 301 | 302 | if(m/=i) p([i,m]) = p([m,i]) 303 | 304 | LU(p(i+1:),i) = LU(p(i+1:),i) / LU(p(i),i) 305 | 306 | forall(j=i+1:N) LU(p(i+1:),j) = LU(p(i+1:),j) - LU(p(i+1:),i) * LU(p(i),j) 307 | end do 308 | 309 | LU = LU(p,:) 310 | end subroutine decomposeLU 311 | 312 | function applyLU(LU,p,b) result(x) 313 | type(ad_t),dimension(:,:),intent(in)::LU 314 | integer,dimension(:),intent(in)::p 315 | type(ad_t),dimension(:),intent(in)::b 316 | type(ad_t),dimension(:),allocatable::x 317 | 318 | type(ad_t),dimension(:),allocatable::pb 319 | type(ad_t),dimension(:),allocatable::r 320 | integer::N,i 321 | 322 | N = size(b) 323 | allocate(r(N),x(N),pb(N)) 324 | r = ad_t(0.0_wp,size(b(1)%grad())) 325 | x = ad_t(0.0_wp,size(b(1)%grad())) 326 | pb = b(p) 327 | 328 | ! L.r=pb 329 | r(1) = pb(1) 330 | do i=2,N,+1 331 | r(i) = pb(i)-sum(LU(i,1:i-1)*r(1:i-1)) 332 | end do 333 | 334 | ! U.x=r 335 | x(N) = r(N)/LU(N,N) 336 | do i=N-1,1,-1 337 | x(i) = ( r(i)-sum(LU(i,i+1:N)*x(i+1:N)) )/LU(i,i) 338 | end do 339 | end function applyLU 340 | 341 | function solveLU_s(A,b) result(x) 342 | type(ad_t),dimension(:,:),intent(in)::A 343 | type(ad_t),dimension(:),intent(in)::b 344 | type(ad_t),dimension(:),allocatable::x 345 | 346 | type(ad_t),dimension(:,:),allocatable::LU 347 | integer,dimension(:),allocatable::p 348 | 349 | call decomposeLU(A,LU,p) 350 | 351 | x = applyLU(LU,p,b) 352 | end function solveLU_s 353 | 354 | function solveLU_m(A,b) result(x) 355 | type(ad_t),dimension(:,:),intent(in)::A 356 | type(ad_t),dimension(:,:),intent(in)::b 357 | type(ad_t),dimension(:,:),allocatable::x 358 | 359 | type(ad_t),dimension(:,:),allocatable::LU 360 | integer,dimension(:),allocatable::p 361 | integer::k 362 | 363 | call decomposeLU(A,LU,p) 364 | 365 | allocate( x(size(b,1),size(b,2)) ) 366 | 367 | do k=1,size(b,2) 368 | x(:,k) = applyLU(LU,p,b(:,k)) 369 | end do 370 | end function solveLU_m 371 | 372 | end module autoDiffArray_mod 373 | -------------------------------------------------------------------------------- /src/autoDiff/autoDiffExponential.f90: -------------------------------------------------------------------------------- 1 | module autoDiffExponential_mod 2 | !! @todo 3 | !! Add cosh and sinh 4 | use constants_mod 5 | use autoDiffType_mod 6 | implicit none 7 | private 8 | 9 | ! Exponential 10 | interface exp 11 | module procedure exp_a 12 | end interface 13 | public::exp 14 | 15 | ! Logarithm 16 | interface log 17 | module procedure log_a 18 | end interface 19 | public::log 20 | 21 | interface log10 22 | module procedure log10_a 23 | end interface 24 | public::log10 25 | 26 | contains 27 | 28 | !===============! 29 | != Exponential =! 30 | !===============! 31 | 32 | elemental function exp_a(u) result(o) 33 | type(ad_t),intent(in)::u 34 | type(ad_t)::o 35 | 36 | o = ad_t( exp(u%x) , exp(u%x)*u%d ) 37 | end function exp_a 38 | 39 | !=============! 40 | != Logarithm =! 41 | !=============! 42 | 43 | elemental function log_a(u) result(o) 44 | type(ad_t),intent(in)::u 45 | type(ad_t)::o 46 | 47 | o = ad_t( log(u%x) , u%d/u%x ) 48 | end function log_a 49 | 50 | elemental function log10_a(u) result(o) 51 | type(ad_t),intent(in)::u 52 | type(ad_t)::o 53 | 54 | o = ad_t( log(u%x)/log10(E) , (u%d/u%x)/log10(E) ) 55 | end function log10_a 56 | 57 | end module autoDiffExponential_mod 58 | -------------------------------------------------------------------------------- /src/autoDiff/autoDiffOperator.f90: -------------------------------------------------------------------------------- 1 | module autoDiffOperator_mod 2 | use autoDiffType_mod 3 | implicit none 4 | private 5 | 6 | ! Assignment 7 | interface assignment(=) 8 | module procedure assign_ra 9 | end interface 10 | public::assignment(=) 11 | 12 | ! Greater-Than 13 | interface operator(>) 14 | module procedure greater_ra 15 | module procedure greater_ar 16 | module procedure greater_aa 17 | end interface 18 | public::operator(>) 19 | 20 | ! Less-Than 21 | interface operator(<) 22 | module procedure less_ra 23 | module procedure less_ar 24 | module procedure less_aa 25 | end interface 26 | public::operator(<) 27 | 28 | ! Addition 29 | interface operator(+) 30 | module procedure add_ra 31 | module procedure add_ar 32 | module procedure add_aa 33 | end interface 34 | public::operator(+) 35 | 36 | ! Subtraction 37 | interface operator(-) 38 | module procedure neg_a 39 | module procedure sub_ra 40 | module procedure sub_ar 41 | module procedure sub_aa 42 | end interface 43 | public::operator(-) 44 | 45 | ! Multiplication 46 | interface operator(*) 47 | module procedure mul_ra 48 | module procedure mul_ar 49 | module procedure mul_aa 50 | end interface 51 | public::operator(*) 52 | 53 | ! Division 54 | interface operator(/) 55 | module procedure div_ra 56 | module procedure div_ar 57 | module procedure div_aa 58 | end interface 59 | public::operator(/) 60 | 61 | ! Power 62 | interface operator(**) 63 | module procedure pow_ra 64 | module procedure pow_ai 65 | module procedure pow_ar 66 | module procedure pow_aa 67 | end interface 68 | public::operator(**) 69 | 70 | ! Square Root 71 | interface sqrt 72 | module procedure sqrt_a 73 | end interface 74 | public::sqrt 75 | 76 | ! Absolute Value 77 | interface abs 78 | module procedure abs_a 79 | end interface 80 | public::abs 81 | 82 | contains 83 | 84 | !==============! 85 | != Assignment =! 86 | !==============! 87 | 88 | elemental subroutine assign_ra(u,v) 89 | real(wp),intent(out)::u 90 | type(ad_t),intent(in)::v 91 | 92 | u = v%x 93 | end subroutine assign_ra 94 | 95 | !================! 96 | != Greater-Than =! 97 | !================! 98 | 99 | function greater_ar(u,v) result(o) 100 | type(ad_t),intent(in)::u 101 | real(wp),intent(in)::v 102 | logical::o 103 | 104 | o = u%x>v 105 | end function greater_ar 106 | 107 | function greater_ra(u,v) result(o) 108 | real(wp),intent(in)::u 109 | type(ad_t),intent(in)::v 110 | logical::o 111 | 112 | o = u>v%x 113 | end function greater_ra 114 | 115 | function greater_aa(u,v) result(o) 116 | type(ad_t),intent(in)::u 117 | type(ad_t),intent(in)::v 118 | logical::o 119 | 120 | o = u%x>v%x 121 | end function greater_aa 122 | 123 | !=============! 124 | != Less-Than =! 125 | !=============! 126 | 127 | function less_ar(u,v) result(o) 128 | type(ad_t),intent(in)::u 129 | real(wp),intent(in)::v 130 | logical::o 131 | 132 | o = u%x j j>=i 290 | type(adZ_t),dimension(:,:),intent(in)::A 291 | type(adZ_t),dimension(:,:),allocatable,intent(inout):: LU 292 | integer,dimension(:),allocatable,intent(inout)::p 293 | integer::N,j,i,m 294 | 295 | LU = A 296 | 297 | N = size(A,1) 298 | p = [( i , i=1,N )] 299 | do i=1,N-1 300 | m = maxloc( abs( LU(p(i:),i) ) , 1 ) + (i-1) 301 | 302 | if(m/=i) p([i,m]) = p([m,i]) 303 | 304 | LU(p(i+1:),i) = LU(p(i+1:),i) / LU(p(i),i) 305 | 306 | forall(j=i+1:N) LU(p(i+1:),j) = LU(p(i+1:),j) - LU(p(i+1:),i) * LU(p(i),j) 307 | end do 308 | 309 | LU = LU(p,:) 310 | end subroutine decomposeLU 311 | 312 | function applyLU(LU,p,b) result(x) 313 | type(adZ_t),dimension(:,:),intent(in)::LU 314 | integer,dimension(:),intent(in)::p 315 | type(adZ_t),dimension(:),intent(in)::b 316 | type(adZ_t),dimension(:),allocatable::x 317 | 318 | type(adZ_t),dimension(:),allocatable::pb 319 | type(adZ_t),dimension(:),allocatable::r 320 | integer::N,i 321 | 322 | N = size(b) 323 | allocate(r(N),x(N),pb(N)) 324 | r = adZ_t( (0.0_wp,0.0_wp) ,size(b(1)%grad())) 325 | x = adZ_t( (0.0_wp,0.0_wp) ,size(b(1)%grad())) 326 | pb = b(p) 327 | 328 | ! L.r=pb 329 | r(1) = pb(1) 330 | do i=2,N,+1 331 | r(i) = pb(i)-sum(LU(i,1:i-1)*r(1:i-1)) 332 | end do 333 | 334 | ! U.x=r 335 | x(N) = r(N)/LU(N,N) 336 | do i=N-1,1,-1 337 | x(i) = ( r(i)-sum(LU(i,i+1:N)*x(i+1:N)) )/LU(i,i) 338 | end do 339 | end function applyLU 340 | 341 | function solveLU_s(A,b) result(x) 342 | type(adZ_t),dimension(:,:),intent(in)::A 343 | type(adZ_t),dimension(:),intent(in)::b 344 | type(adZ_t),dimension(:),allocatable::x 345 | 346 | type(adZ_t),dimension(:,:),allocatable::LU 347 | integer,dimension(:),allocatable::p 348 | 349 | call decomposeLU(A,LU,p) 350 | 351 | x = applyLU(LU,p,b) 352 | end function solveLU_s 353 | 354 | function solveLU_m(A,b) result(x) 355 | type(adZ_t),dimension(:,:),intent(in)::A 356 | type(adZ_t),dimension(:,:),intent(in)::b 357 | type(adZ_t),dimension(:,:),allocatable::x 358 | 359 | type(adZ_t),dimension(:,:),allocatable::LU 360 | integer,dimension(:),allocatable::p 361 | integer::k 362 | 363 | call decomposeLU(A,LU,p) 364 | 365 | allocate( x(size(b,1),size(b,2)) ) 366 | 367 | do k=1,size(b,2) 368 | x(:,k) = applyLU(LU,p,b(:,k)) 369 | end do 370 | end function solveLU_m 371 | 372 | end module autoDiffZArray_mod 373 | -------------------------------------------------------------------------------- /src/autoDiff/autoDiffZExponential.f90: -------------------------------------------------------------------------------- 1 | module autoDiffZExponential_mod 2 | !! @todo 3 | !! Add cosh and sinh 4 | use constants_mod 5 | use autoDiffZType_mod 6 | implicit none 7 | private 8 | 9 | ! Exponential 10 | interface exp 11 | module procedure exp_a 12 | end interface 13 | public::exp 14 | 15 | ! Logarithm 16 | interface log 17 | module procedure log_a 18 | end interface 19 | public::log 20 | 21 | interface log10 22 | module procedure log10_a 23 | end interface 24 | public::log10 25 | 26 | contains 27 | 28 | !===============! 29 | != Exponential =! 30 | !===============! 31 | 32 | elemental function exp_a(u) result(o) 33 | type(adZ_t),intent(in)::u 34 | type(adZ_t)::o 35 | 36 | o = adZ_t( exp(u%x) , exp(u%x)*u%d ) 37 | end function exp_a 38 | 39 | !=============! 40 | != Logarithm =! 41 | !=============! 42 | 43 | elemental function log_a(u) result(o) 44 | type(adZ_t),intent(in)::u 45 | type(adZ_t)::o 46 | 47 | o = adZ_t( log(u%x) , u%d/u%x ) 48 | end function log_a 49 | 50 | elemental function log10_a(u) result(o) 51 | type(adZ_t),intent(in)::u 52 | type(adZ_t)::o 53 | 54 | o = adZ_t( log(u%x)/log10(E) , (u%d/u%x)/log10(E) ) 55 | end function log10_a 56 | 57 | end module autoDiffZExponential_mod 58 | -------------------------------------------------------------------------------- /src/autoDiff/autoDiffZOperator.f90: -------------------------------------------------------------------------------- 1 | module autoDiffZOperator_mod 2 | use autoDiffZType_mod 3 | implicit none 4 | private 5 | 6 | ! Assignment 7 | interface assignment(=) 8 | module procedure assign_ra 9 | end interface 10 | public::assignment(=) 11 | 12 | ! Addition 13 | interface operator(+) 14 | module procedure add_ra 15 | module procedure add_ar 16 | module procedure add_aa 17 | end interface 18 | public::operator(+) 19 | 20 | ! Subtraction 21 | interface operator(-) 22 | module procedure neg_a 23 | module procedure sub_ra 24 | module procedure sub_ar 25 | module procedure sub_aa 26 | end interface 27 | public::operator(-) 28 | 29 | ! Multiplication 30 | interface operator(*) 31 | module procedure mul_ra 32 | module procedure mul_ar 33 | module procedure mul_aa 34 | end interface 35 | public::operator(*) 36 | 37 | ! Division 38 | interface operator(/) 39 | module procedure div_ra 40 | module procedure div_ar 41 | module procedure div_aa 42 | end interface 43 | public::operator(/) 44 | 45 | ! Power 46 | interface operator(**) 47 | module procedure pow_ra 48 | module procedure pow_ai 49 | module procedure pow_ar 50 | module procedure pow_aa 51 | end interface 52 | public::operator(**) 53 | 54 | ! Square Root 55 | interface sqrt 56 | module procedure sqrt_a 57 | end interface 58 | public::sqrt 59 | 60 | ! Absolute Value 61 | interface abs 62 | module procedure abs_a 63 | end interface 64 | public::abs 65 | 66 | contains 67 | 68 | !==============! 69 | != Assignment =! 70 | !==============! 71 | 72 | elemental subroutine assign_ra(u,v) 73 | complex(wp),intent(out)::u 74 | type(adZ_t),intent(in)::v 75 | 76 | u = v%x 77 | end subroutine assign_ra 78 | 79 | !============! 80 | != Addition =! 81 | !============! 82 | 83 | elemental function add_ra(u,v) result(o) 84 | complex(wp),intent(in)::u 85 | type(adZ_t),intent(in)::v 86 | type(adZ_t)::o 87 | 88 | o = adZ_t( u+v%x , v%d ) 89 | end function add_ra 90 | 91 | elemental function add_ar(u,v) result(o) 92 | type(adZ_t),intent(in)::u 93 | complex(wp),intent(in)::v 94 | type(adZ_t)::o 95 | 96 | o = adZ_t( u%x+v , u%d ) 97 | end function add_ar 98 | 99 | elemental function add_aa(u,v) result(o) 100 | type(adZ_t),intent(in)::u 101 | type(adZ_t),intent(in)::v 102 | type(adZ_t)::o 103 | 104 | o = adZ_t( u%x+v%x , u%d+v%d ) 105 | end function add_aa 106 | 107 | !===============! 108 | != Subtraction =! 109 | !===============! 110 | 111 | elemental function neg_a(u) result(o) 112 | type(adZ_t),intent(in)::u 113 | type(adZ_t)::o 114 | 115 | o = adZ_t( -u%x , -u%d ) 116 | end function neg_a 117 | 118 | elemental function sub_ra(u,v) result(o) 119 | complex(wp),intent(in)::u 120 | type(adZ_t),intent(in)::v 121 | type(adZ_t)::o 122 | 123 | o = adZ_t( u-v%x , -v%d ) 124 | end function sub_ra 125 | 126 | elemental function sub_ar(u,v) result(o) 127 | type(adZ_t),intent(in)::u 128 | complex(wp),intent(in)::v 129 | type(adZ_t)::o 130 | 131 | o = adZ_t( u%x-v , u%d ) 132 | end function sub_ar 133 | 134 | elemental function sub_aa(u,v) result(o) 135 | type(adZ_t),intent(in)::u 136 | type(adZ_t),intent(in)::v 137 | type(adZ_t)::o 138 | 139 | o = adZ_t( u%x-v%x , u%d-v%d ) 140 | end function sub_aa 141 | 142 | !==================! 143 | != Multiplication =! 144 | !==================! 145 | 146 | elemental function mul_ra(u,v) result(o) 147 | complex(wp),intent(in)::u 148 | type(adZ_t),intent(in)::v 149 | type(adZ_t)::o 150 | 151 | o = adZ_t( u*v%x , v%d*u ) 152 | end function mul_ra 153 | 154 | elemental function mul_ar(u,v) result(o) 155 | type(adZ_t),intent(in)::u 156 | complex(wp),intent(in)::v 157 | type(adZ_t)::o 158 | 159 | o = adZ_t( u%x*v , u%d*v ) 160 | end function mul_ar 161 | 162 | elemental function mul_aa(u,v) result(o) 163 | type(adZ_t),intent(in)::u 164 | type(adZ_t),intent(in)::v 165 | type(adZ_t)::o 166 | 167 | o = adZ_t( u%x*v%x , u%d*v%x+v%d*u%x ) 168 | end function mul_aa 169 | 170 | !============! 171 | != Division =! 172 | !============! 173 | 174 | elemental function div_ra(u,v) result(o) 175 | complex(wp),intent(in)::u 176 | type(adZ_t),intent(in)::v 177 | type(adZ_t)::o 178 | 179 | o = adZ_t( u/v%x , (-v%d*u)/(v%x**2) ) 180 | end function div_ra 181 | 182 | elemental function div_ar(u,v) result(o) 183 | type(adZ_t),intent(in)::u 184 | complex(wp),intent(in)::v 185 | type(adZ_t)::o 186 | 187 | o = adZ_t( u%x/v , (u%d*v)/(v**2) ) 188 | end function div_ar 189 | 190 | elemental function div_aa(u,v) result(o) 191 | type(adZ_t),intent(in)::u 192 | type(adZ_t),intent(in)::v 193 | type(adZ_t)::o 194 | 195 | o = adZ_t( u%x/v%x , (u%d*v%x-v%d*u%x)/(v%x**2) ) 196 | end function div_aa 197 | 198 | !=========! 199 | != Power =! 200 | !=========! 201 | 202 | elemental function pow_ra(u,v) result(o) 203 | complex(wp),intent(in)::u 204 | type(adZ_t),intent(in)::v 205 | type(adZ_t)::o 206 | 207 | complex(wp)::val 208 | complex(wp),dimension(:),allocatable::grad 209 | 210 | val = u**v%x 211 | grad = u**v%x*( log(u)*v%d ) 212 | 213 | o = adZ_t( val , grad ) 214 | end function pow_ra 215 | 216 | elemental function pow_ai(u,v) result(o) 217 | type(adZ_t),intent(in)::u 218 | integer,intent(in)::v 219 | type(adZ_t)::o 220 | 221 | complex(wp)::val 222 | complex(wp),dimension(:),allocatable::grad 223 | 224 | val = u%x**v 225 | grad = u%x**(v-1)*( real(v,wp)*u%d ) 226 | 227 | o = adZ_t( val , grad ) 228 | end function pow_ai 229 | 230 | elemental function pow_ar(u,v) result(o) 231 | type(adZ_t),intent(in)::u 232 | complex(wp),intent(in)::v 233 | type(adZ_t)::o 234 | 235 | complex(wp)::val 236 | complex(wp),dimension(:),allocatable::grad 237 | 238 | val = u%x**v 239 | ! grad = u%x**v*( v*u%d/u%x ) 240 | grad = u%x**(v-1.0_wp)*( v*u%d ) 241 | 242 | o = adZ_t( val , grad ) 243 | end function pow_ar 244 | 245 | elemental function pow_aa(u,v) result(o) 246 | type(adZ_t),intent(in)::u 247 | type(adZ_t),intent(in)::v 248 | type(adZ_t)::o 249 | 250 | complex(wp)::val 251 | complex(wp),dimension(:),allocatable::grad 252 | 253 | val = u%x**v%x 254 | grad = u%x**v%x*( log(u%x)*v%d+v%x*u%d/u%x ) 255 | 256 | o = adZ_t( val , grad ) 257 | end function pow_aa 258 | 259 | !===============! 260 | != Square Root =! 261 | !===============! 262 | 263 | elemental function sqrt_a(u) result(o) 264 | type(adZ_t),intent(in)::u 265 | type(adZ_t)::o 266 | 267 | o = adZ_t( sqrt(u%x) , u%d/( 2.0_wp*sqrt(u%x) ) ) 268 | end function sqrt_a 269 | 270 | !==================! 271 | != Absolute Value =! 272 | !==================! 273 | 274 | elemental function abs_a(u) result(o) 275 | type(adZ_t),intent(in)::u 276 | type(adZ_t)::o 277 | 278 | !FIXME: This derivative might be wrong 279 | o = adZ_t( abs(u%x) , u%x/abs(u%x)*u%d ) 280 | end function abs_a 281 | 282 | end module autoDiffZOperator_mod 283 | -------------------------------------------------------------------------------- /src/autoDiff/autoDiffZTrigonometric.f90: -------------------------------------------------------------------------------- 1 | module autoDiffZTrigonometric_mod 2 | !! @todo 3 | !! Add inverse operators 4 | use autoDiffZType_mod 5 | implicit none 6 | private 7 | 8 | ! Sine 9 | interface sin 10 | module procedure sin_a 11 | end interface 12 | public::sin 13 | 14 | ! Cosine 15 | interface cos 16 | module procedure cos_a 17 | end interface 18 | public::cos 19 | 20 | ! Tangent 21 | interface tan 22 | module procedure tan_a 23 | end interface 24 | public::tan 25 | 26 | interface atan 27 | module procedure atan_a 28 | end interface 29 | public::atan 30 | 31 | contains 32 | 33 | !========! 34 | != Sine =! 35 | !========! 36 | 37 | elemental function sin_a(u) result(o) 38 | type(adZ_t),intent(in)::u 39 | type(adZ_t)::o 40 | 41 | o = adZ_t( sin(u%x) , cos(u%x)*u%d ) 42 | end function sin_a 43 | 44 | !==========! 45 | != Cosine =! 46 | !==========! 47 | 48 | elemental function cos_a(u) result(o) 49 | type(adZ_t),intent(in)::u 50 | type(adZ_t)::o 51 | 52 | o = adZ_t( cos(u%x) , -sin(u%x)*u%d ) 53 | end function cos_a 54 | 55 | !===========! 56 | != Tangent =! 57 | !===========! 58 | 59 | elemental function tan_a(u) result(o) 60 | type(adZ_t),intent(in)::u 61 | type(adZ_t)::o 62 | 63 | o = adZ_t( tan(u%x) , (tan(u%x)**2+1.0_wp)*u%d ) 64 | end function tan_a 65 | 66 | elemental function atan_a(u) result(o) 67 | type(adZ_t),intent(in)::u 68 | type(adZ_t)::o 69 | 70 | o = adZ_t( atan(u%x) , u%d*(1.0_wp+u%x**2)**(-1) ) 71 | end function atan_a 72 | 73 | end module autoDiffZTrigonometric_mod 74 | -------------------------------------------------------------------------------- /src/autoDiff/autoDiffZType.f90: -------------------------------------------------------------------------------- 1 | module autoDiffZType_mod 2 | !! @todo 3 | !! Add second type for complex numbers 4 | use kinds_mod 5 | implicit none 6 | private 7 | 8 | type::adZ_t 9 | complex(wp)::x 10 | complex(wp),dimension(:),allocatable::d 11 | contains 12 | procedure::val 13 | procedure::der 14 | procedure::grad 15 | end type 16 | 17 | interface adZ_t 18 | module procedure newAD_valIdx 19 | module procedure newAD_valGrad 20 | end interface 21 | 22 | public::adZ_t 23 | 24 | public::wp 25 | 26 | contains 27 | 28 | !================! 29 | != Constructors =! 30 | !================! 31 | 32 | elemental function newAD_valIdx(value,N,idx) result(self) 33 | complex(wp),intent(in)::value 34 | integer,intent(in)::N 35 | integer,intent(in),optional::idx 36 | type(adZ_t)::self 37 | 38 | self%x = value 39 | allocate(self%d(N)) 40 | self%d = 0.0_wp 41 | 42 | if(present(idx)) then 43 | self%d(idx) = 1.0_wp 44 | end if 45 | end function newAD_valIdx 46 | 47 | pure function newAD_valGrad(value,grad) result(self) 48 | complex(wp),intent(in)::value 49 | complex(wp),dimension(:),intent(in)::grad 50 | type(adZ_t)::self 51 | 52 | self%x = value 53 | self%d = grad 54 | end function newAD_valGrad 55 | 56 | !=================! 57 | != adZ_t Routines =! 58 | !=================! 59 | 60 | elemental function val(self) result(o) 61 | class(adZ_t),intent(in)::self 62 | complex(wp)::o 63 | 64 | o = self%x 65 | end function val 66 | 67 | elemental function der(self,idx) result(o) 68 | class(adZ_t),intent(in)::self 69 | integer,intent(in)::idx 70 | complex(wp)::o 71 | 72 | o = self%d(idx) 73 | end function der 74 | 75 | pure function grad(self) result(o) 76 | class(adZ_t),intent(in)::self 77 | complex(wp),dimension(:),allocatable::o 78 | 79 | o = self%d 80 | end function grad 81 | 82 | !=============! 83 | != Utilities =! 84 | !=============! 85 | 86 | end module autoDiffZType_mod 87 | -------------------------------------------------------------------------------- /src/constants.f90: -------------------------------------------------------------------------------- 1 | module constants_mod 2 | !! Module to manage basic constants 3 | use kinds_mod 4 | implicit none 5 | 6 | !==================! 7 | != Math Constants =! 8 | !==================! 9 | 10 | real(wp),parameter::PI = 4.0_wp*atan(1.0_wp) 11 | !! Archimedes' constant 12 | real(wp),parameter::E = exp(1.0_wp) 13 | !! Euler's constant 14 | 15 | !===========! 16 | != Exports =! 17 | !===========! 18 | 19 | public::PI,E 20 | 21 | ! Kinds 22 | public::wp 23 | 24 | contains 25 | 26 | elemental function arg(z) result(v) 27 | !! Compute the argument of a complex number 28 | complex(wp),intent(in)::z 29 | real(wp)::v 30 | 31 | v = atan2(aimag(z),real(z)) 32 | end function arg 33 | 34 | end module constants_mod 35 | 36 | -------------------------------------------------------------------------------- /src/expression/expression.f90: -------------------------------------------------------------------------------- 1 | module expression_mod 2 | !! Module for dynamic evaluation of function expressions 3 | !! @todo 4 | !! Add ability to take derivative 5 | use node_mod 6 | use treeValue_mod 7 | use treeOperator_mod 8 | use treeExponential_mod 9 | use treeTrigonometric_mod 10 | implicit none 11 | private 12 | 13 | !==================================! 14 | != function_t Type and Interfaces =! 15 | !==================================! 16 | 17 | type::function_t 18 | !! Type to store and evaluate parsed expressions 19 | character(:),allocatable::str 20 | class(node_t),allocatable::root 21 | contains 22 | procedure,private::evalR 23 | procedure,private::evalZ 24 | generic::eval => evalR, evalZ 25 | end type 26 | 27 | interface function_t 28 | !! Constructors for function_t 29 | module procedure newFunction 30 | end interface 31 | 32 | !===========! 33 | != Exports =! 34 | !===========! 35 | 36 | public::function_t 37 | 38 | contains 39 | 40 | !=======================! 41 | != function_t Routines =! 42 | !=======================! 43 | 44 | function newFunction(str) result(self) 45 | !! Constructor for function_t 46 | character(*),intent(in)::str 47 | !! Character to parse into function 48 | type(function_t)::self 49 | !! New function_t 50 | 51 | type(token_t),dimension(:),allocatable::ar 52 | type(token_t),dimension(:),allocatable::ex 53 | integer::ek 54 | 55 | self%str = removeSpaces(str) 56 | 57 | ek = scan(self%str,'=') 58 | ar = toRPN(tokenize(self%str(:ek-1))) 59 | ex = toRPN(tokenize(self%str(ek+1:))) 60 | 61 | allocate(self%root,source=toTree( ex , ar%s )) 62 | end function newFunction 63 | 64 | function evalR(self,a) result(o) 65 | !! Evaluate a function with given arguments 66 | class(function_t),intent(inout)::self 67 | !! Function to evaluate 68 | real(wp),dimension(:),intent(in)::a 69 | !! Argument values 70 | real(wp)::o 71 | !! Resultant value 72 | 73 | o = self%root%eval(a) 74 | end function evalR 75 | 76 | function evalZ(self,a) result(o) 77 | !! Evaluate a function with given arguments 78 | class(function_t),intent(inout)::self 79 | !! Function to evaluate 80 | complex(wp),dimension(:),intent(in)::a 81 | !! Argument values 82 | complex(wp)::o 83 | !! Resultant value 84 | 85 | o = self%root%eval(a) 86 | end function evalZ 87 | 88 | function toTree(tks,args) result(o) 89 | !! Convert an RPN list into an evaluation tree 90 | type(token_t),dimension(:),intent(in)::tks 91 | !! List of tokens in RPN order 92 | character(*),dimension(:),intent(in)::args 93 | !! Names of variables in proper order 94 | class(node_t),allocatable::o 95 | !! Evaluation tree 96 | 97 | type(nodeStack_t)::stk 98 | class(node_t),allocatable::l1,l2 99 | integer::N,M,i,k,idx 100 | 101 | N = size(tks) 102 | M = size(args) 103 | 104 | stk = nodeStack_t(N) 105 | 106 | do k=1,N 107 | select case( tks(k)%t ) 108 | case(T_VAR) 109 | do i=1,M 110 | if( tks(k)%s/=args(i) ) cycle 111 | idx = i 112 | end do 113 | call stk%push( newVar(idx) ) 114 | case(T_REAL) 115 | call stk%push( newReal(tks(k)%a) ) 116 | case(T_IMAG) 117 | call stk%push( newImag(tks(k)%a) ) 118 | case(T_ADD) 119 | allocate(l1,source=stk%pop()) 120 | allocate(l2,source=stk%pop()) 121 | call stk%push( newAdd(l2,l1) ) 122 | case(T_SUB) 123 | allocate(l1,source=stk%pop()) 124 | allocate(l2,source=stk%pop()) 125 | call stk%push( newSub(l2,l1) ) 126 | case(T_MUL) 127 | allocate(l1,source=stk%pop()) 128 | allocate(l2,source=stk%pop()) 129 | call stk%push( newMul(l2,l1) ) 130 | case(T_DIV) 131 | allocate(l1,source=stk%pop()) 132 | allocate(l2,source=stk%pop()) 133 | call stk%push( newDiv(l2,l1) ) 134 | case(T_POW) 135 | allocate(l1,source=stk%pop()) 136 | allocate(l2,source=stk%pop()) 137 | call stk%push( newPow(l2,l1) ) 138 | case(T_NEG) 139 | call stk%push( newNeg( stk%pop() ) ) 140 | case(T_SQRT) 141 | call stk%push( newSqrt( stk%pop() ) ) 142 | case(T_EXP) 143 | call stk%push( newExp( stk%pop() ) ) 144 | case(T_LOG) 145 | call stk%push( newLog( stk%pop() ) ) 146 | case(T_ABS) 147 | call stk%push( newAbs( stk%pop() ) ) 148 | case(T_SIN) 149 | call stk%push( newSin( stk%pop() ) ) 150 | case(T_COS) 151 | call stk%push( newCos( stk%pop() ) ) 152 | case(T_TAN) 153 | call stk%push( newTan( stk%pop() ) ) 154 | case(T_ASIN) 155 | call stk%push( newAsin( stk%pop() ) ) 156 | case(T_ACOS) 157 | call stk%push( newAcos( stk%pop() ) ) 158 | case(T_ATAN) 159 | call stk%push( newAtan( stk%pop() ) ) 160 | case(T_LOG10) 161 | call stk%push( newLog10( stk%pop() ) ) 162 | end select 163 | 164 | if(allocated(l1)) deallocate(l1) 165 | if(allocated(l2)) deallocate(l2) 166 | end do 167 | 168 | allocate( o,source=stk%pop() ) 169 | end function toTree 170 | 171 | end module expression_mod 172 | -------------------------------------------------------------------------------- /src/expression/node.f90: -------------------------------------------------------------------------------- 1 | module node_mod 2 | use text_mod 3 | implicit none 4 | public 5 | 6 | !==============================! 7 | != node_t Type and Interfaces =! 8 | !==============================! 9 | 10 | type,abstract::node_t 11 | contains 12 | procedure(evalR_p),deferred,private::evalR 13 | procedure(evalZ_p),deferred,private::evalZ 14 | generic::eval => evalR,evalZ 15 | end type 16 | 17 | interface 18 | function evalR_p(self,args) result(o) 19 | import 20 | class(node_t),intent(in)::self 21 | real(wp),dimension(:),intent(in)::args 22 | real(wp)::o 23 | end function evalR_p 24 | 25 | function evalZ_p(self,args) result(o) 26 | import 27 | class(node_t),intent(in)::self 28 | complex(wp),dimension(:),intent(in)::args 29 | complex(wp)::o 30 | end function evalZ_p 31 | end interface 32 | 33 | !===================================! 34 | != nodeStack_t Type and Interfaces =! 35 | !===================================! 36 | 37 | type::genericNode_t 38 | class(node_t),allocatable::node 39 | end type 40 | 41 | type::nodeStack_t 42 | integer,private::N = 0 43 | integer,private::D = 0 44 | type(genericNode_t),dimension(:),allocatable::levels 45 | contains 46 | procedure::pop 47 | procedure::push 48 | end type 49 | 50 | interface nodeStack_t 51 | module procedure newNodeStack 52 | end interface 53 | 54 | !======================! 55 | != token_t Parameters =! 56 | !======================! 57 | 58 | character(8),parameter::ops = ',+-*/^()' 59 | 60 | integer,parameter::R_SPAN = 99 61 | 62 | integer,parameter::T_NONE = -1 63 | integer,parameter::T_REAL = -2 64 | integer,parameter::T_IMAG = -3 65 | integer,parameter::T_VAR = -4 66 | 67 | integer,parameter::T_CMA = 001 68 | integer,parameter::T_LPR = 002 69 | integer,parameter::T_RPR = 003 70 | 71 | integer,parameter::T_OPERATOR = 200 72 | integer,parameter::T_ADD = 201 73 | integer,parameter::T_SUB = 202 74 | integer,parameter::T_MUL = 203 75 | integer,parameter::T_DIV = 204 76 | integer,parameter::T_POW = 205 77 | 78 | integer,parameter::T_FUNCTION = 100 79 | integer,parameter::T_NEG = 101 80 | integer,parameter::T_SQRT = 102 81 | integer,parameter::T_EXP = 103 82 | integer,parameter::T_LOG = 104 83 | integer,parameter::T_ABS = 105 84 | integer,parameter::T_SIN = 106 85 | integer,parameter::T_COS = 107 86 | integer,parameter::T_TAN = 108 87 | integer,parameter::T_ASIN = 109 88 | integer,parameter::T_ACOS = 110 89 | integer,parameter::T_ATAN = 111 90 | integer,parameter::T_LOG10 = 112 91 | 92 | !===============================! 93 | != token_t Type and Interfaces =! 94 | !===============================! 95 | 96 | type::token_t 97 | !! Type for a single mathematical token 98 | integer::t = T_NONE 99 | !! Token type 100 | real(wp)::a = 0.0_wp 101 | !! Token real value (if any) 102 | character(8)::s = '' 103 | !! Token label (if any) 104 | end type 105 | 106 | interface token_t 107 | !! Constructors for token_t 108 | module procedure newToken 109 | end interface 110 | 111 | contains 112 | 113 | 114 | !========================! 115 | != nodeStack_t Routines =! 116 | !========================! 117 | 118 | function newNodeStack(N) result(self) 119 | integer,intent(in)::N 120 | type(nodeStack_t)::self 121 | 122 | self%N = N 123 | self%D = 0 124 | allocate(self%levels(N)) 125 | end function newNodeStack 126 | 127 | function pop(self) result(o) 128 | class(nodeStack_t),intent(inout)::self 129 | class(node_t),allocatable::o 130 | integer::k 131 | 132 | if(self%D==0) then 133 | stop 'Tried to pop with empty stack' 134 | end if 135 | 136 | allocate(o,source=self%levels(1)%node) 137 | do k=1,min(self%D,self%N-1) 138 | self%levels(k) = self%levels(k+1) 139 | end do 140 | 141 | if(self%N==self%D) then 142 | if(allocated(self%levels(self%N)%node)) deallocate(self%levels(self%N)%node) 143 | end if 144 | 145 | self%D = self%D-1 146 | end function pop 147 | 148 | subroutine push(self,a) 149 | class(nodeStack_t),intent(inout)::self 150 | class(node_t),intent(in)::a 151 | integer::k 152 | 153 | if(self%D==self%N) then 154 | stop 'Tried to push a full stack' 155 | end if 156 | 157 | do k=self%D+1,2,-1 158 | self%levels(k) = self%levels(k-1) 159 | end do 160 | if(allocated(self%levels(1)%node)) deallocate(self%levels(1)%node) 161 | allocate(self%levels(1)%node,source=a) 162 | 163 | self%D = self%D+1 164 | end subroutine push 165 | 166 | 167 | !====================! 168 | != token_t Routines =! 169 | !====================! 170 | 171 | function newToken(str) result(self) 172 | !! Constructor for token_t 173 | character(*),intent(in)::str 174 | !! String to parse 175 | type(token_t)::self 176 | !! New token_t 177 | 178 | character(:),allocatable::buf 179 | 180 | self%s = str 181 | if(verify(str,ops)==0) then 182 | select case(str) 183 | case(',') 184 | self%t = T_CMA 185 | case('(') 186 | self%t = T_LPR 187 | case(')') 188 | self%t = T_RPR 189 | case('+') 190 | self%t = T_ADD 191 | case('-') 192 | self%t = T_SUB 193 | case('*') 194 | self%t = T_MUL 195 | case('/') 196 | self%t = T_DIV 197 | case('^') 198 | self%t = T_POW 199 | end select 200 | else if(verify(str,' .+-0123456789E')==0) then 201 | self%t = T_REAL 202 | read(str,*) self%a 203 | else if(verify(str,' .+-0123456789EJj')==0) then 204 | self%t = T_IMAG 205 | buf = removeJ(str) 206 | read(buf,*) self%a 207 | else if(str=='sqrt') then 208 | self%t = T_SQRT 209 | else if(str=='exp') then 210 | self%t = T_EXP 211 | else if(str=='log') then 212 | self%t = T_LOG 213 | else if(str=='abs') then 214 | self%t = T_ABS 215 | else if(str=='sin') then 216 | self%t = T_SIN 217 | else if(str=='cos') then 218 | self%t = T_COS 219 | else if(str=='tan') then 220 | self%t = T_TAN 221 | else if(str=='asin') then 222 | self%t = T_ASIN 223 | else if(str=='acos') then 224 | self%t = T_ACOS 225 | else if(str=='atan') then 226 | self%t = T_ATAN 227 | else if(str=='log10') then 228 | self%t = T_LOG10 229 | else 230 | self%t = T_VAR 231 | end if 232 | 233 | contains 234 | 235 | function removeJ(str) result(o) 236 | character(*),intent(in)::str 237 | character(:),allocatable::o 238 | 239 | character(1),dimension(:),allocatable::a,b 240 | 241 | a = charToArray(str) 242 | b = pack(a, a/='j' .and. a/='J' ) 243 | o = arrayToChar(b) 244 | end function removeJ 245 | 246 | end function newToken 247 | 248 | !===================! 249 | != Helper Routines =! 250 | !===================! 251 | 252 | function toRPN(tks) result(o) 253 | !! Convert a list of tokens from read order into RPN 254 | !! 255 | !! Uses the shunting-yard algorithm 256 | type(token_t),dimension(:),intent(in)::tks 257 | !! Input tokens in read order 258 | type(token_t),dimension(:),allocatable::o 259 | !! Output list in RPN 260 | 261 | type(token_t),dimension(:),allocatable::s 262 | integer::ok,sk,k 263 | 264 | allocate(o(size(tks))) 265 | allocate(s(size(tks))) 266 | ok = 0 267 | sk = 0 268 | 269 | do k=1,size(tks) 270 | select case(tks(k)%t) 271 | case(T_REAL,T_IMAG,T_VAR) 272 | ok = ok+1 273 | o(ok) = tks(k) 274 | case(T_FUNCTION:T_FUNCTION+R_SPAN) 275 | sk = sk+1 276 | s(sk) = tks(k) 277 | case(T_LPR) 278 | sk = sk+1 279 | s(sk) = tks(k) 280 | case(T_RPR) 281 | do while(s(sk)%t/=T_LPR) 282 | ok = ok+1 283 | o(ok) = s(sk) 284 | sk = sk-1 285 | end do 286 | sk = sk-1 287 | if(sk/=0) then 288 | if(s(sk)%t>=T_FUNCTION .and. s(sk)%tT_OPERATOR .and. s(sk)%t0) 310 | ok = ok+1 311 | o(ok) = s(sk) 312 | sk = sk-1 313 | end do 314 | 315 | o = pack(o,o%t/=T_NONE) 316 | end function toRPN 317 | 318 | function tokenize(str) result(o) 319 | !! Split a character into tokens 320 | character(*),intent(in)::str 321 | !! Character to split 322 | type(token_t),dimension(:),allocatable::o 323 | !! Resulting list of tokens 324 | 325 | character(64)::t 326 | integer::s,n,k 327 | 328 | allocate(o(0)) 329 | s = 1 330 | 331 | do while(sT_OPERATOR .and. o(k-1)%t evalR_exp 15 | procedure::evalZ => evalZ_exp 16 | end type 17 | 18 | interface exp_t 19 | module procedure newExp 20 | end interface 21 | 22 | ! log_t 23 | type,extends(node_t)::log_t 24 | class(node_t),allocatable::a 25 | contains 26 | procedure::evalR => evalR_log 27 | procedure::evalZ => evalZ_log 28 | end type 29 | 30 | interface log_t 31 | module procedure newLog 32 | end interface 33 | 34 | ! log10_t 35 | type,extends(node_t)::log10_t 36 | class(node_t),allocatable::a 37 | contains 38 | procedure::evalR => evalR_log10 39 | procedure::evalZ => evalZ_log10 40 | end type 41 | 42 | interface log10_t 43 | module procedure newLog10 44 | end interface 45 | 46 | contains 47 | 48 | !============================! 49 | != Evaluation Tree Routines =! 50 | !============================! 51 | 52 | ! exp_t 53 | function newExp(a) result(self) 54 | class(node_t),intent(in)::a 55 | type(exp_t)::self 56 | 57 | allocate(self%a,source=a) 58 | end function newExp 59 | 60 | function evalR_exp(self,args) result(o) 61 | class(exp_t),intent(in)::self 62 | real(wp),dimension(:),intent(in)::args 63 | real(wp)::o 64 | 65 | o = exp( self%a%eval(args) ) 66 | end function evalR_exp 67 | 68 | function evalZ_exp(self,args) result(o) 69 | class(exp_t),intent(in)::self 70 | complex(wp),dimension(:),intent(in)::args 71 | complex(wp)::o 72 | 73 | o = exp( self%a%eval(args) ) 74 | end function evalZ_exp 75 | 76 | ! log_t 77 | function newLog(a) result(self) 78 | class(node_t),intent(in)::a 79 | type(log_t)::self 80 | 81 | allocate(self%a,source=a) 82 | end function newLog 83 | 84 | function evalR_log(self,args) result(o) 85 | class(log_t),intent(in)::self 86 | real(wp),dimension(:),intent(in)::args 87 | real(wp)::o 88 | 89 | o = log( self%a%eval(args) ) 90 | end function evalR_log 91 | 92 | function evalZ_log(self,args) result(o) 93 | class(log_t),intent(in)::self 94 | complex(wp),dimension(:),intent(in)::args 95 | complex(wp)::o 96 | 97 | o = log( self%a%eval(args) ) 98 | end function evalZ_log 99 | 100 | ! log10_t 101 | function newLog10(a) result(self) 102 | class(node_t),intent(in)::a 103 | type(log10_t)::self 104 | 105 | allocate(self%a,source=a) 106 | end function newLog10 107 | 108 | function evalR_log10(self,args) result(o) 109 | class(log10_t),intent(in)::self 110 | real(wp),dimension(:),intent(in)::args 111 | real(wp)::o 112 | 113 | o = log10( self%a%eval(args) ) 114 | end function evalR_log10 115 | 116 | function evalZ_log10(self,args) result(o) 117 | use ieee_arithmetic 118 | class(log10_t),intent(in)::self 119 | complex(wp),dimension(:),intent(in)::args 120 | complex(wp)::o 121 | 122 | o = ieee_value(0.0_wp,IEEE_QUIET_NAN) 123 | stop 'Log of complex argument not supported' 124 | end function evalZ_log10 125 | 126 | end module treeExponential_mod 127 | -------------------------------------------------------------------------------- /src/expression/treeOperator.f90: -------------------------------------------------------------------------------- 1 | module treeOperator_mod 2 | use node_mod 3 | implicit none 4 | public 5 | 6 | !========================================! 7 | != Evaluation Tree Types and Interfaces =! 8 | !========================================! 9 | 10 | ! add_t 11 | type,extends(node_t)::add_t 12 | class(node_t),allocatable::a 13 | class(node_t),allocatable::b 14 | contains 15 | procedure::evalR => evalR_add 16 | procedure::evalZ => evalZ_add 17 | end type 18 | 19 | interface add_t 20 | module procedure newAdd 21 | end interface 22 | 23 | ! sub_t 24 | type,extends(node_t)::sub_t 25 | class(node_t),allocatable::a 26 | class(node_t),allocatable::b 27 | contains 28 | procedure::evalR => evalR_sub 29 | procedure::evalZ => evalZ_sub 30 | end type 31 | 32 | interface sub_t 33 | module procedure newSub 34 | end interface 35 | 36 | ! mul_t 37 | type,extends(node_t)::mul_t 38 | class(node_t),allocatable::a 39 | class(node_t),allocatable::b 40 | contains 41 | procedure::evalR => evalR_mul 42 | procedure::evalZ => evalZ_mul 43 | end type 44 | 45 | interface mul_t 46 | module procedure newMul 47 | end interface 48 | 49 | ! div_t 50 | type,extends(node_t)::div_t 51 | class(node_t),allocatable::a 52 | class(node_t),allocatable::b 53 | contains 54 | procedure::evalR => evalR_div 55 | procedure::evalZ => evalZ_div 56 | end type 57 | 58 | interface div_t 59 | module procedure newDiv 60 | end interface 61 | 62 | ! pow_t 63 | type,extends(node_t)::pow_t 64 | class(node_t),allocatable::a 65 | class(node_t),allocatable::b 66 | contains 67 | procedure::evalR => evalR_pow 68 | procedure::evalZ => evalZ_pow 69 | end type 70 | 71 | interface pow_t 72 | module procedure newPow 73 | end interface 74 | 75 | ! neg_t 76 | type,extends(node_t)::neg_t 77 | class(node_t),allocatable::a 78 | contains 79 | procedure::evalR => evalR_neg 80 | procedure::evalZ => evalZ_neg 81 | end type 82 | 83 | interface neg_t 84 | module procedure newNeg 85 | end interface 86 | 87 | ! sqrt_t 88 | type,extends(node_t)::sqrt_t 89 | class(node_t),allocatable::a 90 | contains 91 | procedure::evalR => evalR_sqrt 92 | procedure::evalZ => evalZ_sqrt 93 | end type 94 | 95 | interface sqrt_t 96 | module procedure newSqrt 97 | end interface 98 | 99 | ! abs_t 100 | type,extends(node_t)::abs_t 101 | class(node_t),allocatable::a 102 | contains 103 | procedure::evalR => evalR_abs 104 | procedure::evalZ => evalZ_abs 105 | end type 106 | 107 | interface abs_t 108 | module procedure newAbs 109 | end interface 110 | 111 | contains 112 | 113 | !============================! 114 | != Evaluation Tree Routines =! 115 | !============================! 116 | 117 | ! add_t 118 | function newAdd(a,b) result(self) 119 | class(node_t),intent(in)::a 120 | class(node_t),intent(in)::b 121 | type(add_t)::self 122 | 123 | allocate(self%a,source=a) 124 | allocate(self%b,source=b) 125 | end function newAdd 126 | 127 | function evalR_add(self,args) result(o) 128 | class(add_t),intent(in)::self 129 | real(wp),dimension(:),intent(in)::args 130 | real(wp)::o 131 | 132 | o = self%a%eval(args)+self%b%eval(args) 133 | end function evalR_add 134 | 135 | function evalZ_add(self,args) result(o) 136 | class(add_t),intent(in)::self 137 | complex(wp),dimension(:),intent(in)::args 138 | complex(wp)::o 139 | 140 | o = self%a%eval(args)+self%b%eval(args) 141 | end function evalZ_add 142 | 143 | ! sub_t 144 | function newSub(a,b) result(self) 145 | class(node_t),intent(in)::a 146 | class(node_t),intent(in)::b 147 | type(sub_t)::self 148 | 149 | allocate(self%a,source=a) 150 | allocate(self%b,source=b) 151 | end function newSub 152 | 153 | function evalR_sub(self,args) result(o) 154 | class(sub_t),intent(in)::self 155 | real(wp),dimension(:),intent(in)::args 156 | real(wp)::o 157 | 158 | o = self%a%eval(args)-self%b%eval(args) 159 | end function evalR_sub 160 | 161 | function evalZ_sub(self,args) result(o) 162 | class(sub_t),intent(in)::self 163 | complex(wp),dimension(:),intent(in)::args 164 | complex(wp)::o 165 | 166 | o = self%a%eval(args)-self%b%eval(args) 167 | end function evalZ_sub 168 | 169 | ! mul_t 170 | function newMul(a,b) result(self) 171 | class(node_t),intent(in)::a 172 | class(node_t),intent(in)::b 173 | type(mul_t)::self 174 | 175 | allocate(self%a,source=a) 176 | allocate(self%b,source=b) 177 | end function newMul 178 | 179 | function evalR_mul(self,args) result(o) 180 | class(mul_t),intent(in)::self 181 | real(wp),dimension(:),intent(in)::args 182 | real(wp)::o 183 | 184 | o = self%a%eval(args)*self%b%eval(args) 185 | end function evalR_mul 186 | 187 | function evalZ_mul(self,args) result(o) 188 | class(mul_t),intent(in)::self 189 | complex(wp),dimension(:),intent(in)::args 190 | complex(wp)::o 191 | 192 | o = self%a%eval(args)*self%b%eval(args) 193 | end function evalZ_mul 194 | 195 | ! div_t 196 | function newDiv(a,b) result(self) 197 | class(node_t),intent(in)::a 198 | class(node_t),intent(in)::b 199 | type(div_t)::self 200 | 201 | allocate(self%a,source=a) 202 | allocate(self%b,source=b) 203 | end function newDiv 204 | 205 | function evalR_div(self,args) result(o) 206 | class(div_t),intent(in)::self 207 | real(wp),dimension(:),intent(in)::args 208 | real(wp)::o 209 | 210 | o = self%a%eval(args)/self%b%eval(args) 211 | end function evalR_div 212 | 213 | function evalZ_div(self,args) result(o) 214 | class(div_t),intent(in)::self 215 | complex(wp),dimension(:),intent(in)::args 216 | complex(wp)::o 217 | 218 | o = self%a%eval(args)/self%b%eval(args) 219 | end function evalZ_div 220 | 221 | ! pow_t 222 | function newPow(a,b) result(self) 223 | class(node_t),intent(in)::a 224 | class(node_t),intent(in)::b 225 | type(pow_t)::self 226 | 227 | allocate(self%a,source=a) 228 | allocate(self%b,source=b) 229 | end function newPow 230 | 231 | function evalR_pow(self,args) result(o) 232 | class(pow_t),intent(in)::self 233 | real(wp),dimension(:),intent(in)::args 234 | real(wp)::o 235 | 236 | o = self%a%eval(args)**self%b%eval(args) 237 | end function evalR_pow 238 | 239 | function evalZ_pow(self,args) result(o) 240 | class(pow_t),intent(in)::self 241 | complex(wp),dimension(:),intent(in)::args 242 | complex(wp)::o 243 | 244 | o = self%a%eval(args)**self%b%eval(args) 245 | end function evalZ_pow 246 | 247 | ! neg_t 248 | function newNeg(a) result(self) 249 | class(node_t),intent(in)::a 250 | type(neg_t)::self 251 | 252 | allocate(self%a,source=a) 253 | end function newNeg 254 | 255 | function evalR_neg(self,args) result(o) 256 | class(neg_t),intent(in)::self 257 | real(wp),dimension(:),intent(in)::args 258 | real(wp)::o 259 | 260 | o = -self%a%eval(args) 261 | end function evalR_neg 262 | 263 | function evalZ_neg(self,args) result(o) 264 | class(neg_t),intent(in)::self 265 | complex(wp),dimension(:),intent(in)::args 266 | complex(wp)::o 267 | 268 | o = -self%a%eval(args) 269 | end function evalZ_neg 270 | 271 | ! sqrt_t 272 | function newSqrt(a) result(self) 273 | class(node_t),intent(in)::a 274 | type(sqrt_t)::self 275 | 276 | allocate(self%a,source=a) 277 | end function newSqrt 278 | 279 | function evalR_sqrt(self,args) result(o) 280 | class(sqrt_t),intent(in)::self 281 | real(wp),dimension(:),intent(in)::args 282 | real(wp)::o 283 | 284 | o = sqrt( self%a%eval(args) ) 285 | end function evalR_sqrt 286 | 287 | function evalZ_sqrt(self,args) result(o) 288 | class(sqrt_t),intent(in)::self 289 | complex(wp),dimension(:),intent(in)::args 290 | complex(wp)::o 291 | 292 | o = sqrt( self%a%eval(args) ) 293 | end function evalZ_sqrt 294 | 295 | ! abs_t 296 | function newAbs(a) result(self) 297 | class(node_t),intent(in)::a 298 | type(abs_t)::self 299 | 300 | allocate(self%a,source=a) 301 | end function newAbs 302 | 303 | function evalR_abs(self,args) result(o) 304 | class(abs_t),intent(in)::self 305 | real(wp),dimension(:),intent(in)::args 306 | real(wp)::o 307 | 308 | o = abs( self%a%eval(args) ) 309 | end function evalR_abs 310 | 311 | function evalZ_abs(self,args) result(o) 312 | class(abs_t),intent(in)::self 313 | complex(wp),dimension(:),intent(in)::args 314 | complex(wp)::o 315 | 316 | o = abs( self%a%eval(args) ) 317 | end function evalZ_abs 318 | 319 | end module treeOperator_mod 320 | -------------------------------------------------------------------------------- /src/expression/treeTrigonometric.f90: -------------------------------------------------------------------------------- 1 | module treeTrigonometric_mod 2 | use node_mod 3 | implicit none 4 | public 5 | 6 | !========================================! 7 | != Evaluation Tree Types and Interfaces =! 8 | !========================================! 9 | 10 | ! sin_t 11 | type,extends(node_t)::sin_t 12 | class(node_t),allocatable::a 13 | contains 14 | procedure::evalR => evalR_sin 15 | procedure::evalZ => evalZ_sin 16 | end type 17 | 18 | interface sin_t 19 | module procedure newSin 20 | end interface 21 | 22 | ! cos_t 23 | type,extends(node_t)::cos_t 24 | class(node_t),allocatable::a 25 | contains 26 | procedure::evalR => evalR_cos 27 | procedure::evalZ => evalZ_cos 28 | end type 29 | 30 | interface cos_t 31 | module procedure newCos 32 | end interface 33 | 34 | ! tan_t 35 | type,extends(node_t)::tan_t 36 | class(node_t),allocatable::a 37 | contains 38 | procedure::evalR => evalR_tan 39 | procedure::evalZ => evalZ_tan 40 | end type 41 | 42 | interface tan_t 43 | module procedure newTan 44 | end interface 45 | 46 | ! asin_t 47 | type,extends(node_t)::asin_t 48 | class(node_t),allocatable::a 49 | contains 50 | procedure::evalR => evalR_asin 51 | procedure::evalZ => evalZ_asin 52 | end type 53 | 54 | interface asin_t 55 | module procedure newAsin 56 | end interface 57 | 58 | ! acos_t 59 | type,extends(node_t)::acos_t 60 | class(node_t),allocatable::a 61 | contains 62 | procedure::evalR => evalR_acos 63 | procedure::evalZ => evalZ_acos 64 | end type 65 | 66 | interface acos_t 67 | module procedure newAcos 68 | end interface 69 | 70 | ! atan_t 71 | type,extends(node_t)::atan_t 72 | class(node_t),allocatable::a 73 | contains 74 | procedure::evalR => evalR_atan 75 | procedure::evalZ => evalZ_atan 76 | end type 77 | 78 | interface atan_t 79 | module procedure newAtan 80 | end interface 81 | 82 | contains 83 | 84 | !============================! 85 | != Evaluation Tree Routines =! 86 | !============================! 87 | 88 | ! sin_t 89 | function newSin(a) result(self) 90 | class(node_t),intent(in)::a 91 | type(sin_t)::self 92 | 93 | allocate(self%a,source=a) 94 | end function newSin 95 | 96 | function evalR_sin(self,args) result(o) 97 | class(sin_t),intent(in)::self 98 | real(wp),dimension(:),intent(in)::args 99 | real(wp)::o 100 | 101 | o = sin( self%a%eval(args) ) 102 | end function evalR_sin 103 | 104 | function evalZ_sin(self,args) result(o) 105 | class(sin_t),intent(in)::self 106 | complex(wp),dimension(:),intent(in)::args 107 | complex(wp)::o 108 | 109 | o = sin( self%a%eval(args) ) 110 | end function evalZ_sin 111 | 112 | ! cos_t 113 | function newCos(a) result(self) 114 | class(node_t),intent(in)::a 115 | type(cos_t)::self 116 | 117 | allocate(self%a,source=a) 118 | end function newCos 119 | 120 | function evalR_cos(self,args) result(o) 121 | class(cos_t),intent(in)::self 122 | real(wp),dimension(:),intent(in)::args 123 | real(wp)::o 124 | 125 | o = cos( self%a%eval(args) ) 126 | end function evalR_cos 127 | 128 | function evalZ_cos(self,args) result(o) 129 | class(cos_t),intent(in)::self 130 | complex(wp),dimension(:),intent(in)::args 131 | complex(wp)::o 132 | 133 | o = cos( self%a%eval(args) ) 134 | end function evalZ_cos 135 | 136 | ! tan_t 137 | function newTan(a) result(self) 138 | class(node_t),intent(in)::a 139 | type(tan_t)::self 140 | 141 | allocate(self%a,source=a) 142 | end function newTan 143 | 144 | function evalR_tan(self,args) result(o) 145 | class(tan_t),intent(in)::self 146 | real(wp),dimension(:),intent(in)::args 147 | real(wp)::o 148 | 149 | o = tan( self%a%eval(args) ) 150 | end function evalR_tan 151 | 152 | function evalZ_tan(self,args) result(o) 153 | class(tan_t),intent(in)::self 154 | complex(wp),dimension(:),intent(in)::args 155 | complex(wp)::o 156 | 157 | o = tan( self%a%eval(args) ) 158 | end function evalZ_tan 159 | 160 | ! asin_t 161 | function newAsin(a) result(self) 162 | class(node_t),intent(in)::a 163 | type(asin_t)::self 164 | 165 | allocate(self%a,source=a) 166 | end function newAsin 167 | 168 | function evalR_asin(self,args) result(o) 169 | class(asin_t),intent(in)::self 170 | real(wp),dimension(:),intent(in)::args 171 | real(wp)::o 172 | 173 | o = asin( self%a%eval(args) ) 174 | end function evalR_asin 175 | 176 | function evalZ_asin(self,args) result(o) 177 | class(asin_t),intent(in)::self 178 | complex(wp),dimension(:),intent(in)::args 179 | complex(wp)::o 180 | 181 | o = asin( self%a%eval(args) ) 182 | end function evalZ_asin 183 | 184 | ! acos_t 185 | function newAcos(a) result(self) 186 | class(node_t),intent(in)::a 187 | type(acos_t)::self 188 | 189 | allocate(self%a,source=a) 190 | end function newAcos 191 | 192 | function evalR_acos(self,args) result(o) 193 | class(acos_t),intent(in)::self 194 | real(wp),dimension(:),intent(in)::args 195 | real(wp)::o 196 | 197 | o = acos( self%a%eval(args) ) 198 | end function evalR_acos 199 | 200 | function evalZ_acos(self,args) result(o) 201 | class(acos_t),intent(in)::self 202 | complex(wp),dimension(:),intent(in)::args 203 | complex(wp)::o 204 | 205 | o = acos( self%a%eval(args) ) 206 | end function evalZ_acos 207 | 208 | ! atan_t 209 | function newAtan(a) result(self) 210 | class(node_t),intent(in)::a 211 | type(atan_t)::self 212 | 213 | allocate(self%a,source=a) 214 | end function newAtan 215 | 216 | function evalR_atan(self,args) result(o) 217 | class(atan_t),intent(in)::self 218 | real(wp),dimension(:),intent(in)::args 219 | real(wp)::o 220 | 221 | o = atan( self%a%eval(args) ) 222 | end function evalR_atan 223 | 224 | function evalZ_atan(self,args) result(o) 225 | class(atan_t),intent(in)::self 226 | complex(wp),dimension(:),intent(in)::args 227 | complex(wp)::o 228 | 229 | o = atan( self%a%eval(args) ) 230 | end function evalZ_atan 231 | 232 | end module treeTrigonometric_mod 233 | -------------------------------------------------------------------------------- /src/expression/treeValue.f90: -------------------------------------------------------------------------------- 1 | module treeValue_mod 2 | use node_mod 3 | implicit none 4 | public 5 | 6 | !========================================! 7 | != Evaluation Tree Types and Interfaces =! 8 | !========================================! 9 | 10 | ! real_t 11 | type,extends(node_t)::real_t 12 | real(wp)::value 13 | contains 14 | procedure::evalR => evalR_real 15 | procedure::evalZ => evalZ_real 16 | end type 17 | 18 | interface real_t 19 | module procedure newReal 20 | end interface 21 | 22 | ! imag_t 23 | type,extends(node_t)::imag_t 24 | real(wp)::value 25 | contains 26 | procedure::evalR => evalR_imag 27 | procedure::evalZ => evalZ_imag 28 | end type 29 | 30 | interface imag_t 31 | module procedure newImag 32 | end interface 33 | 34 | ! var_t 35 | type,extends(node_t)::var_t 36 | integer::idx 37 | contains 38 | procedure::evalR => evalR_var 39 | procedure::evalZ => evalZ_var 40 | end type 41 | 42 | interface var_t 43 | module procedure newVar 44 | end interface 45 | 46 | contains 47 | 48 | !============================! 49 | != Evaluation Tree Routines =! 50 | !============================! 51 | 52 | ! real_t 53 | function newReal(value) result(self) 54 | real(wp),intent(in)::value 55 | type(real_t)::self 56 | 57 | self%value = value 58 | end function newReal 59 | 60 | function evalR_real(self,args) result(o) 61 | class(real_t),intent(in)::self 62 | real(wp),dimension(:),intent(in)::args 63 | real(wp)::o 64 | 65 | o = self%value 66 | end function evalR_real 67 | 68 | function evalZ_real(self,args) result(o) 69 | class(real_t),intent(in)::self 70 | complex(wp),dimension(:),intent(in)::args 71 | complex(wp)::o 72 | 73 | o = self%value 74 | end function evalZ_real 75 | 76 | ! imag_t 77 | function newImag(value) result(self) 78 | real(wp),intent(in)::value 79 | type(imag_t)::self 80 | 81 | self%value = value 82 | end function newImag 83 | 84 | function evalR_imag(self,args) result(o) 85 | use ieee_arithmetic 86 | class(imag_t),intent(in)::self 87 | real(wp),dimension(:),intent(in)::args 88 | real(wp)::o 89 | 90 | o = ieee_value(0.0_wp,IEEE_QUIET_NAN) 91 | stop 'Imaginary number encountered in real evaluation' 92 | end function evalR_imag 93 | 94 | function evalZ_imag(self,args) result(o) 95 | class(imag_t),intent(in)::self 96 | complex(wp),dimension(:),intent(in)::args 97 | complex(wp)::o 98 | 99 | o = self%value 100 | end function evalZ_imag 101 | 102 | ! var_t 103 | function newVar(idx) result(self) 104 | integer,intent(in)::idx 105 | type(var_t)::self 106 | 107 | self%idx = idx 108 | end function newVar 109 | 110 | function evalR_var(self,args) result(o) 111 | class(var_t),intent(in)::self 112 | real(wp),dimension(:),intent(in)::args 113 | real(wp)::o 114 | 115 | integer::N 116 | 117 | N = size(args) 118 | 119 | if(self%idx>N) then 120 | write(*,*) 'Invalid argument index: '//intToChar(self%idx) 121 | stop 'Error in eval_var' 122 | end if 123 | 124 | o = args(self%idx) 125 | end function evalR_var 126 | 127 | function evalZ_var(self,args) result(o) 128 | class(var_t),intent(in)::self 129 | complex(wp),dimension(:),intent(in)::args 130 | complex(wp)::o 131 | 132 | integer::N 133 | 134 | N = size(args) 135 | 136 | if(self%idx>N) then 137 | write(*,*) 'Invalid argument index: '//intToChar(self%idx) 138 | stop 'Error in eval_var' 139 | end if 140 | 141 | o = args(self%idx) 142 | end function evalZ_var 143 | 144 | end module treeValue_mod 145 | -------------------------------------------------------------------------------- /src/fftw3.f90: -------------------------------------------------------------------------------- 1 | module fftw3_mod 2 | use iso_c_binding 3 | implicit none 4 | 5 | include 'fftw3.f03' 6 | 7 | end module fftw3_mod -------------------------------------------------------------------------------- /src/generate-unitsParameters.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | #==========# 4 | #= Length =# 5 | #==========# 6 | 7 | Length = {} 8 | Length[' m' ] = 1.0 9 | 10 | Length['cm'] = 1.0E-2 11 | Length['mm'] = 1.0E-3 12 | Length['um'] = 1.0E-6 13 | Length['nm'] = 1.0E-9 14 | Length['km'] = 1.0E3 15 | Length['AU'] = 1.4960E11 16 | Length['ly'] = 9.4607E15 17 | Length['pc'] = 3.0857E16 18 | 19 | Length['yd'] = 0.9144 20 | Length['ft'] = 0.3048 21 | Length['in'] = 0.0254 22 | Length['mi'] = 1.609344E3 23 | 24 | #========# 25 | #= Mass =# 26 | #========# 27 | 28 | Mass = {} 29 | Mass[' kg'] = 1.0 30 | 31 | Mass['g' ] = 1.0E-3 32 | Mass['mg'] = 1.0E-6 33 | Mass['u' ] = 1.66053904020E-27 34 | 35 | Mass['slug' ] = 14.5939029372 36 | Mass['lbm' ] = 0.45359237 37 | Mass['stone'] = 6.35029 38 | 39 | #========# 40 | #= Time =# 41 | #========# 42 | 43 | Time = {} 44 | Time[' s'] = 1.0 45 | 46 | Time['ms'] = 1.0E-3 47 | Time['us'] = 1.0E-6 48 | Time['ns'] = 1.0E-9 49 | Time['min'] = 60.0 50 | Time['hr' ] = 3600.0 51 | Time['d' ] = 86400.0 52 | Time['yr'] = 3.154E7 53 | 54 | #===============# 55 | #= Temperature =# 56 | #===============# 57 | 58 | Temp = {} 59 | Temp[' K'] = 1.0 60 | 61 | Temp[' R'] = 0.5555555555555556 62 | 63 | #===================# 64 | #= Composite Units =# 65 | #===================# 66 | 67 | Comp = {} 68 | 69 | Comp['N' ] = {' kg':1,' m':1,' s':-2} 70 | Comp['lbf'] = {'slug':1,'ft':1,' s':-2} 71 | 72 | Comp['Pa' ] = {' kg':1,' m':-1,' s':-2} 73 | Comp['psi'] = {'slug':1,'ft':1,'in':-2,' s':-2} 74 | 75 | Comp['kph'] = {'km':1,'hr':-1} 76 | Comp['mph'] = {'mi':1,'hr':-1} 77 | 78 | Comp['J' ] = {' kg':1,' m':2,' s':-2} 79 | Comp['btu'] = {' kg':1,' m':2,' s':-2,'_scale':1055.06} 80 | 81 | Comp['W' ] = {' kg':1,' m':2,' s':-3} 82 | Comp['hp' ] = {' kg':1,' m':2,' s':-3,'_scale':745.7} 83 | 84 | #===================# 85 | #= Code Generators =# 86 | #===================# 87 | 88 | def getParameters(D,pre): 89 | N = len(D) 90 | lines = [] 91 | 92 | lines.append('\tinteger,parameter::%(pre)s_COUNT = %(count)d'%{'pre':pre,'count':N}) 93 | 94 | lines.append('\tcharacter(10),dimension(%(pre)s_COUNT)::%(pre)s_NAMES = [character(10):: &'%{'pre':pre}) 95 | buf = '\t\t&' 96 | keys = sorted(D.keys()) 97 | for k in range(len(keys)): 98 | buf = '%s \'%s\''%(buf,keys[k].lstrip()) 99 | if k 0 = Directly scaled 108 | character(*),intent(in),optional::lineColor 109 | !! Color of vectors 110 | character(*),intent(in),optional::lineStyle 111 | !! Style of vectors' lines 112 | real(wp),optional::lineWidth 113 | !! Width of vectors' lines 114 | 115 | real(pp),dimension(:),allocatable::xl,yl 116 | real(pp),dimension(:,:),allocatable::ul,vl,sl 117 | real(pp),dimension(2)::xb,yb,sb,cb,d 118 | real(pp)::scalingl,scl,mag,clr 119 | integer::i,j 120 | 121 | xl = localize(x) 122 | yl = localize(y) 123 | ul = localize(u) 124 | vl = localize(v) 125 | 126 | d = real([x(2)-x(1),y(2)-y(1)],pp) 127 | 128 | xb = real(mixval(x),pp) 129 | yb = real(mixval(y),pp) 130 | if(present(s)) then 131 | sl = localize(s) 132 | sl = sl/maxval(sl) 133 | else 134 | sl = localize(u**2+v**2) 135 | sl = sqrt(sl) 136 | sl = sl/maxval(sl) 137 | end if 138 | sb = [minval(sl),maxval(sl)] 139 | cb = 0.0_wp 140 | if(present(c)) cb = real([minval(c),maxval(c)],pp) 141 | 142 | scalingl = 1.0_pp 143 | if(present(scaling)) scalingl = real(scaling,pp) 144 | 145 | if(present(lineColor)) call setColor(lineColor) 146 | if(present(lineStyle)) call setLineStyle(lineStyle) 147 | if(present(lineWidth)) call setLineWidth(lineWidth) 148 | 149 | do i=1,size(u,1) 150 | do j=1,size(u,2) 151 | mag = norm2([ul(i,j),vl(i,j)]) 152 | scl = scalingl*norm2(d)*sl(i,j) 153 | if(abs(scl)<1.0E-5_wp) cycle 154 | if(present(c)) then 155 | clr = real( (c(i,j)-cb(1))/(cb(2)-cb(1)) ,pp) 156 | clr = max(clr,0.0_pp) 157 | clr = min(clr,1.0_pp) 158 | call plcol1( clr ) 159 | end if 160 | call plvect(ul(i:i,j:j)/mag,vl(i:i,j:j)/mag,scl,xl(i:i),yl(j:j)) 161 | end do 162 | end do 163 | 164 | call resetPen() 165 | end subroutine quiver 166 | 167 | subroutine fill(x,y,c,cR) 168 | !! Fill a polygon 169 | real(wp),dimension(:),intent(in)::x 170 | !! x-positions of vectors 171 | real(wp),dimension(:),intent(in)::y 172 | !! y-positions of vectors 173 | real(wp),intent(in)::c 174 | !! Color values for vectors 175 | real(wp),dimension(2),intent(in)::cR 176 | !! Range of color variable 177 | 178 | real(pp),dimension(:),allocatable::xl,yl 179 | real(pp)::clr 180 | 181 | xl = localize(x) 182 | yl = localize(y) 183 | 184 | clr = real( (c-cR(1))/(cR(2)-cR(1)) ,pp) 185 | clr = max(clr,0.0_pp) 186 | clr = min(clr,1.0_pp) 187 | call plcol1( clr ) 188 | 189 | call plfill(xl,yl) 190 | 191 | call resetPen() 192 | end subroutine fill 193 | 194 | end module plplotlib2D_mod 195 | -------------------------------------------------------------------------------- /src/plplotlib/plplotlib3D.f90: -------------------------------------------------------------------------------- 1 | module plplotlib3D_mod 2 | !! Wrapper module for plplot to give it a more matplotlib like personality 3 | use plplotlibBase_mod 4 | implicit none 5 | public 6 | 7 | contains 8 | 9 | !=====================! 10 | != Plotting Routines =! 11 | !=====================! 12 | 13 | subroutine plot3(x,y,z,lineColor,lineStyle,lineWidth,markColor,markStyle,markSize) 14 | !! Plot data using lines and or markers 15 | real(wp),dimension(:),intent(in)::x 16 | !! x-data for plot 17 | real(wp),dimension(:),intent(in)::y 18 | !! y-data for plot 19 | real(wp),dimension(:),intent(in)::z 20 | !! z-data for plot 21 | character(*),intent(in),optional::lineColor 22 | !! Color of line 23 | character(*),intent(in),optional::lineStyle 24 | !! Style of line; '' for no line 25 | real(wp),intent(in),optional::lineWidth 26 | !! Width of line 27 | character(*),intent(in),optional::markColor 28 | !! Color of markers, if any 29 | character(*),intent(in),optional::markStyle 30 | !! Style of markers; '' or absent for none 31 | real(wp),intent(in),optional::markSize 32 | !! Size of markers, if any 33 | 34 | real(pp),dimension(:),allocatable::xl,yl,zl 35 | real(pp)::dx,dy,dz,sx,sy,sz 36 | character(32)::code 37 | integer::k 38 | 39 | xl = localize(x) 40 | yl = localize(y) 41 | zl = localize(z) 42 | 43 | if(present(lineColor)) call setColor(lineColor) 44 | if(present(lineWidth)) call setLineWidth(lineWidth) 45 | if(present(lineStyle)) then 46 | call setLineStyle(lineStyle) 47 | if(lineStyle/='') call plline(xl,yl) 48 | else 49 | call plline3(xl,yl,zl) 50 | end if 51 | call resetPen() 52 | 53 | if(present(markColor)) call setColor(markColor) 54 | if(present(markSize)) call plssym(0.0_pp,real(markSize,pp)) 55 | if(present(markStyle)) then 56 | code = getSymbolCode(markStyle) 57 | if(markStyle/='') then 58 | dx = 1.0_pp 59 | dy = 0.0_pp 60 | dz = 0.0_pp 61 | sx = 0.0_pp 62 | sy = 0.0_pp 63 | sz = 0.0_pp 64 | do k=1,size(x) 65 | call plptex3(xl(k),yl(k),zl(k),dx,dy,dz,sx,sy,sz,0.5_pp,code) 66 | end do 67 | end if 68 | end if 69 | call resetPen() 70 | end subroutine plot3 71 | 72 | subroutine surface(x,y,z,N,lineStyle) 73 | !! Plot a 3d surface 74 | real(wp),dimension(:),intent(in)::x 75 | !! x-coordinates of data 76 | real(wp),dimension(:),intent(in)::y 77 | !! y-coordinates of data 78 | real(wp),dimension(:,:),intent(in)::z 79 | !! Data for contouring 80 | integer,intent(in),optional::N 81 | !! Number of levels to use in surface colors 82 | character(*),intent(in),optional::lineStyle 83 | !! Style for xy lines ( '-' = on, '' = off ) 84 | 85 | real(pp),dimension(:),allocatable::xl,yl 86 | real(pp),dimension(:,:),allocatable::zl 87 | 88 | real(pp),dimension(:),allocatable::edge 89 | integer::Nl,opt 90 | 91 | opt = MAG_COLOR 92 | 93 | xl = localize(x) 94 | yl = localize(y) 95 | zl = localize(z) 96 | Nl = 20 97 | if(present(N)) then 98 | Nl = N 99 | opt = ior(opt,SURF_CONT) 100 | end if 101 | edge = localize(linspace(minval(z),maxval(z),Nl)) 102 | 103 | if(present(lineStyle)) then 104 | select case(lineStyle) 105 | case('') 106 | opt = opt 107 | case('-') 108 | opt = ior(opt,FACETED) 109 | end select 110 | end if 111 | 112 | call plsurf3d(xl,yl,zl,opt,edge) 113 | call resetPen() 114 | end subroutine surface 115 | 116 | subroutine wireframe(x,y,z,lineColor) 117 | !! Plot a 3d wireframe 118 | real(wp),dimension(:),intent(in)::x 119 | !! x-coordinates of data 120 | real(wp),dimension(:),intent(in)::y 121 | !! y-coordinates of data 122 | real(wp),dimension(:,:),intent(in)::z 123 | !! Data for contouring 124 | character(*),intent(in),optional::lineColor 125 | !! Color of contour lines 126 | 127 | real(pp),dimension(:),allocatable::xl,yl 128 | real(pp),dimension(:,:),allocatable::zl 129 | 130 | xl = localize(x) 131 | yl = localize(y) 132 | zl = localize(z) 133 | 134 | if(present(lineColor)) then 135 | call setColor(lineColor) 136 | call plot3d(xl,yl,zl,DRAW_LINEXY,.false.) 137 | else 138 | call plot3d(xl,yl,zl,ior(DRAW_LINEXY,MAG_COLOR),.false.) 139 | end if 140 | 141 | call resetPen() 142 | end subroutine wireframe 143 | 144 | end module plplotlib3D_mod 145 | -------------------------------------------------------------------------------- /src/stats.f90: -------------------------------------------------------------------------------- 1 | module stats_mod 2 | !! Basic probability and statistics module 3 | use constants_mod 4 | use kinds_mod 5 | implicit none 6 | private 7 | 8 | !==============! 9 | != Interfaces =! 10 | !==============! 11 | 12 | interface randomUniform 13 | !! Return sample(s) \(x\) from a uniform distribution such that \(x\in[-1,1]\) 14 | module procedure randomUniform_s 15 | module procedure randomUniform_a1 16 | end interface randomUniform 17 | 18 | interface randomNormal 19 | !! Return sample(s) \(x\) from an approximate normal distribution such that \(x\in[-6,6]\), \( \sigma \approx 1.0 \) and \( \mu \approx 0.0 \). 20 | module procedure randomNormal_s 21 | module procedure randomNormal_a1 22 | end interface 23 | 24 | !===========! 25 | != Exports =! 26 | !===========! 27 | 28 | public::setRandomSeed 29 | 30 | public::randomUniform 31 | public::randomNormal 32 | public::randomInteger 33 | 34 | public::mean 35 | public::stDev 36 | 37 | public::KDE 38 | 39 | ! Types 40 | public::wp 41 | 42 | contains 43 | 44 | !========================! 45 | != Probability Routines =! 46 | !========================! 47 | 48 | subroutine setRandomSeed(S) 49 | !! Set the pseudo-random number generator seed 50 | integer::S 51 | integer::k,N 52 | 53 | call random_seed(size=N) 54 | call random_seed(put=[(k-1,k=1,N)]*S) 55 | end subroutine setRandomSeed 56 | 57 | function randomUniform_s() result(o) 58 | !! Return a sample from a uniform distribution 59 | !! in the range \(x\in[-1,1]\). 60 | real(wp)::o 61 | !! Pseudo-random number 62 | 63 | call random_number(o) 64 | o = o*2.0_wp-1.0_wp 65 | end function randomUniform_s 66 | 67 | function randomUniform_a1(N) result(o) 68 | !! Return \(N\) samples from a uniform distribution 69 | !! in the range \(x\in[-1,1]\). 70 | integer,intent(in)::N 71 | !! Number of samples 72 | real(wp),dimension(:),allocatable::o 73 | !! Pseudo-random number array 74 | 75 | integer::k 76 | 77 | allocate(o(N)) 78 | 79 | do k=1,N 80 | o(k) = randomUniform_s() 81 | end do 82 | end function randomUniform_a1 83 | 84 | function randomNormal_s() result(o) 85 | !! Return a sample from an approximate normal distribution 86 | !! with a mean of \( \mu \approx 0.0\) and a standard deviation of 87 | !! \( \sigma \approx 1.0 \). In this approximate distribution, \(x\in[-6,6]\). 88 | real(wp)::o 89 | !! Pseudo-random number 90 | 91 | real(wp),dimension(12)::x 92 | 93 | call random_number(x) 94 | o = sum(x)-6.0_wp 95 | end function randomNormal_s 96 | 97 | function randomNormal_a1(N) result(o) 98 | !! Return \(N\) samples from an approximate normal distribution 99 | !! with a mean of \(\mu=0\) and a standard deviation of 100 | !! \(\sigma=1\). In this approximate distribution, \(x\in[-6,6]\). 101 | integer,intent(in)::N 102 | !! Number of samples 103 | real(wp),dimension(:),allocatable::o 104 | !! Pseudo-random number array 105 | 106 | integer::k 107 | 108 | allocate(o(N)) 109 | 110 | do k=1,N 111 | o(k) = randomNormal_s() 112 | end do 113 | end function randomNormal_a1 114 | 115 | function randomInteger(N) result(o) 116 | !! Return a random integer \(i\in[1,N]\) 117 | integer,intent(in)::N 118 | !! Upper limit of range 119 | integer::o 120 | !! Random integer 121 | 122 | real(wp)::x 123 | 124 | x = (randomUniform()+1.0_wp)/2.0_wp 125 | 126 | o = floor(x*real(N,wp)+1.0_wp) 127 | end function randomInteger 128 | 129 | !================================! 130 | != Population Property Routines =! 131 | !================================! 132 | 133 | function mean(d) result(o) 134 | !! Compute the mean of an input array 135 | real(wp),dimension(:),intent(in)::d 136 | !! Data to process 137 | real(wp)::o 138 | !! Mean 139 | 140 | o = sum(d)/real(size(d),wp) 141 | end function mean 142 | 143 | function stDev(d) result(o) 144 | !! Compute the standard deviation of an input array 145 | real(wp),dimension(:),intent(in)::d 146 | !! Data to process 147 | real(wp)::o 148 | !! Standard deviation 149 | 150 | o = sqrt(sum((d-sum(d)/real(size(d),wp))**2)/real(size(d)-1,wp)) 151 | end function stDev 152 | 153 | !============================! 154 | != Kernel Density Estimator =! 155 | !============================! 156 | 157 | function KDE(sample,rng) result(p) 158 | real(wp),dimension(:),intent(in)::sample 159 | !! Set of samples for density estimation 160 | real(wp),dimension(:),intent(in)::rng 161 | !! Range over which to compute the density 162 | real(wp),dimension(:),allocatable::p 163 | !! Estimated density of samples over range 164 | 165 | real(wp),dimension(:),allocatable::x 166 | integer::Ns,Nr,k 167 | real(wp)::h 168 | 169 | Ns = size(sample) 170 | Nr = size(rng) 171 | 172 | h = bandwidth(sample) 173 | allocate(p(Nr)) 174 | p = 0.0_wp 175 | do k=1,Ns 176 | x = (rng-sample(k))/h 177 | p = p+(1.0_wp/(real(Ns,wp)*h))*kernel(x) 178 | end do 179 | 180 | contains 181 | 182 | elemental function kernel(x) result(p) 183 | real(wp),intent(in)::x 184 | !! Independent variable 185 | real(wp)::p 186 | !! Kernel value 187 | 188 | real(wp)::m,s 189 | 190 | m = 0.0_wp 191 | s = 1.0_wp 192 | p = (1/sqrt(2*PI*s**2))*exp(-(x-m)**2/(2.0_wp*s**2)) 193 | end function kernel 194 | 195 | function bandwidth(sample) result(h) 196 | real(wp),dimension(:),intent(in)::sample 197 | !! Sample data 198 | real(wp)::h 199 | !! Bandwidth 200 | 201 | integer::N 202 | 203 | N = size(sample) 204 | h = 1.05_wp*stDev(sample)*real(N,wp)**(-1.0_wp/5.0_wp) 205 | end function bandwidth 206 | 207 | end function KDE 208 | 209 | end module stats_mod 210 | -------------------------------------------------------------------------------- /src/test/testArray.f90: -------------------------------------------------------------------------------- 1 | program testArray_prg 2 | !! Test program for array_mod 3 | use array_mod 4 | implicit none 5 | 6 | call testMixval 7 | call testSpan 8 | call testFlatten 9 | 10 | call testDeDup 11 | 12 | call testLinspace 13 | call testMeshGrid 14 | 15 | call testLinearInterp 16 | 17 | call testTDMA 18 | call testLU 19 | 20 | call testPoly 21 | 22 | contains 23 | 24 | subroutine testMixval 25 | !! Test mixval to verify operation 26 | logical,dimension(1)::results 27 | 28 | integer,parameter::N = 10 29 | real(wp),dimension(N)::x 30 | real(wp),dimension(2)::test,true 31 | 32 | call random_number(x) 33 | 34 | test = mixval(x) 35 | true = [minval(x),maxval(x)] 36 | 37 | results(1) = all(test==true) 38 | 39 | if( .not.all(results) ) error stop "Failed mixval check" 40 | end subroutine testMixval 41 | 42 | subroutine testSpan 43 | !! Test mixval to verify operation 44 | logical,dimension(1)::results 45 | 46 | integer,parameter::N = 10 47 | real(wp),dimension(N)::x 48 | real(wp)::test,true 49 | 50 | call random_number(x) 51 | 52 | test = span(x) 53 | true = maxval(x)-minval(x) 54 | 55 | results(1) = test==true 56 | 57 | if( .not.all(results) ) error stop "Failed span check" 58 | end subroutine testSpan 59 | 60 | subroutine testFlatten 61 | !! Test mixval to verify operation 62 | logical,dimension(1)::results 63 | 64 | integer,parameter::N = 3 65 | integer,parameter::M = 4 66 | real(wp),dimension(N,M)::x 67 | real(wp),dimension(N*M)::y 68 | 69 | call random_number(x) 70 | y = flatten(x) 71 | 72 | results(1) = all( abs(y-reshape(x,[N*M]))<2.0_wp**4*epsilon(1.0_wp) ) 73 | 74 | if( .not.all(results) ) error stop "Failed flatten check" 75 | end subroutine testFlatten 76 | 77 | subroutine testDeDup 78 | !! Test deDup to verify operation 79 | logical,dimension(1)::results 80 | 81 | results(1) = all( deDup([1,1,2,3,2,4])==[1,2,3,4] ) 82 | 83 | if( .not.all(results) ) error stop "Failed deDup check" 84 | end subroutine testDeDup 85 | 86 | subroutine testLinspace 87 | !! Test linspace to verify operation 88 | logical,dimension(1)::results 89 | 90 | real(wp),dimension(:),allocatable::x,y 91 | integer::N,k 92 | 93 | N = 100 94 | x = linspace(0.0_wp,1.0_wp,N) 95 | y = [( real(k-1,wp)/real(N-1,wp) , k=1,N )] 96 | 97 | results(1) = norm2(x-y)<1.0E-10_wp 98 | 99 | if( .not.all(results) ) error stop "Failed linspace check" 100 | end subroutine testLinspace 101 | 102 | subroutine testMeshGrid 103 | !! Test meshGridX and meshGridY to verify operation 104 | logical,dimension(6)::results 105 | 106 | real(wp),dimension(:),allocatable::x,y 107 | real(wp),dimension(:,:),allocatable::XX,YY 108 | integer::N,M 109 | 110 | N = 5 111 | M = 6 112 | 113 | x = linspace(0.0_wp,1.0_wp,N) 114 | y = linspace(0.0_wp,1.0_wp,M) 115 | 116 | XX = meshGridX(x,y) 117 | YY = meshGridY(x,y) 118 | 119 | results(1) = all(XX(:,1)==x) 120 | results(2) = all(YY(1,:)==y) 121 | results(3) = all(XX(:,1)==XX(:,M)) 122 | results(4) = all(YY(1,:)==YY(N,:)) 123 | results(5) = all(shape(XX)==[N,M]) 124 | results(6) = all(shape(YY)==[N,M]) 125 | 126 | if( .not.all(results) ) error stop "Failed linspace check" 127 | end subroutine testMeshGrid 128 | 129 | subroutine testLinearInterp 130 | !! Test linearInterp to verify operation 131 | logical,dimension(1)::results 132 | 133 | real(wp),dimension(:),allocatable::x1,x2,y 134 | integer::N,k 135 | 136 | N = 100 137 | 138 | x1 = linspace(0.0_wp,5.0_wp,N) 139 | x2 = linspace(0.0_wp,5.0_wp,N/4) 140 | 141 | allocate(y(N)) 142 | do k=1,N 143 | y(k) = linearInterp(x1(k),x2,2.0_wp*x2) 144 | end do 145 | 146 | results(1) = norm2(y-2.0_wp*x1)<1.0E-10_wp 147 | 148 | if( .not.all(results) ) error stop "Failed linearInterp check" 149 | end subroutine testLinearInterp 150 | 151 | subroutine testTDMA 152 | !! Test TDMA to verify operation 153 | 154 | real(wp),dimension(:,:),allocatable::A 155 | real(wp),dimension(:),allocatable::b,x,xt 156 | 157 | integer::N,k 158 | 159 | N = 10 160 | 161 | allocate( A(N,-1:+1) , x(N) , b(N) ) 162 | xt = linspace(0.0_wp,1.0_wp,N) 163 | 164 | A(1,-1:+1) = [0.0_wp,1.0_wp,0.0_wp] 165 | b( 1 ) = 0.0_wp 166 | 167 | do k=2,N-1 168 | A(k,-1) = 1.0_wp 169 | A(k, 0) = -2.0_wp 170 | A(k,+1) = 1.0_wp 171 | b( k ) = 0.0_wp 172 | end do 173 | 174 | A(N,-1:+1) = [0.0_wp,1.0_wp,0.0_wp] 175 | b( N ) = 1.0_wp 176 | 177 | x = TDMA(A,b) 178 | 179 | do k=1,N 180 | write(*,*) xt(k),x(k) 181 | end do 182 | 183 | write(*,*) norm2(xt-x) 184 | end subroutine testTDMA 185 | 186 | subroutine testLU 187 | !! Test solveLU to verify operation 188 | 189 | real(wp),dimension(:,:),allocatable::A 190 | real(wp),dimension(:),allocatable::x,b,bc 191 | integer::N 192 | 193 | do N=2,100 194 | if(allocated(A)) deallocate(A) 195 | if(allocated(b)) deallocate(b) 196 | 197 | allocate( A(N,N) , b(N) ) 198 | 199 | call random_number(A) 200 | call random_number(b) 201 | 202 | x = solveLU(A,b) 203 | bc = matmul(A,x) 204 | 205 | if( norm2(bc-b)>1.0E-10_wp ) stop 'solveLU Failed' 206 | end do 207 | end subroutine testLU 208 | 209 | subroutine testPoly 210 | !! Test polyfit 211 | 212 | real(wp),dimension(:),allocatable::x,y,f 213 | real(wp),dimension(:),allocatable::p,t,d,g 214 | integer::N 215 | 216 | N = 10 217 | x = linspace(0.0_wp,3.0_wp,N) 218 | y = -1.0_wp+x**2 219 | 220 | p = polyfit(x,y,2) 221 | t = [-1.0_wp,0.0_wp,1.0_wp] 222 | write(*,*) t-p 223 | if( norm2(t-p)>1.0E-10_wp ) stop 'polyfit Failed' 224 | 225 | f = polyval(p,x) 226 | write(*,*) y-f 227 | if( norm2(y-f)>1.0E-10_wp ) stop 'polyval Failed' 228 | 229 | d = polyder(p) 230 | g = [0.0_wp,2.0_wp] 231 | write(*,*) g-d 232 | if( norm2(g-d)>1.0E-10_wp ) stop 'polyder Failed' 233 | end subroutine testPoly 234 | 235 | end program testArray_prg 236 | -------------------------------------------------------------------------------- /src/test/testAutoDiff.f90: -------------------------------------------------------------------------------- 1 | program testAutoDiff_prg 2 | !! Test program for autoDiff_mod 3 | !! @todo 4 | !! Needs serious improvements 5 | use autoDiff_mod 6 | implicit none 7 | 8 | call testDiff 9 | 10 | contains 11 | 12 | subroutine testDiff 13 | type(ad_t)::x 14 | 15 | x = ad_t(1.0_wp,1,1) 16 | end subroutine testDiff 17 | 18 | end program testAutoDiff_prg 19 | 20 | -------------------------------------------------------------------------------- /src/test/testConfig.f90: -------------------------------------------------------------------------------- 1 | program testConfig_prg 2 | !! Test program for config_mod 3 | !! @todo 4 | !! Add tests for each datatype 5 | use config_mod 6 | use text_mod 7 | implicit none 8 | 9 | call testNewConfig 10 | 11 | contains 12 | 13 | subroutine testNewConfig 14 | !! Verify the operation of newConfig 15 | logical,dimension(1)::results 16 | type(config_t)::cfg 17 | 18 | logical::tLogical 19 | integer::tInteger 20 | real(wp)::tReal 21 | complex(wp)::tComplex 22 | real(wp),dimension(:),allocatable::tVector 23 | real(wp),dimension(:,:),allocatable::tMatrix 24 | character(:),allocatable::tString 25 | 26 | cfg = config_t('./input/testConfig.cfg') 27 | call cfg%writeContents(stdout) 28 | 29 | results(1) = allocated(cfg%pairs) 30 | 31 | tLogical = cfg%getLogical('logical') 32 | tInteger = cfg%getInteger('integer') 33 | tReal = cfg%getReal('real') 34 | tComplex = cfg%getComplex('complex') 35 | tVector = cfg%getVector('vector') 36 | tMatrix = cfg%getMatrix('matrix') 37 | tString = cfg%getString('string') 38 | 39 | if( .not.all(results) ) error stop "Failed newConfig check" 40 | end subroutine testNewConfig 41 | 42 | end program testConfig_prg 43 | -------------------------------------------------------------------------------- /src/test/testConstants.f90: -------------------------------------------------------------------------------- 1 | program testConstants_prg 2 | !! Test program for kinds_mod 3 | use constants_mod 4 | implicit none 5 | 6 | call testConstants 7 | 8 | contains 9 | 10 | subroutine testConstants 11 | !! Test standard constants and verify accuracy to type-level precision 12 | character(41),parameter::cPI = '3.141592653589793238462643383279502884197' 13 | character(41),parameter::cE = '2.718281828459045235360287471352662497757' 14 | 15 | integer::dPI,dE 16 | 17 | dPI = checkPrecision(PI,cPI) 18 | dE = checkPrecision( E,cE ) 19 | 20 | if( any([dPI,dE]=5) then 42 | call fill(lx,ly,sum(lf)/real(size(lf),wp),fR) 43 | else 44 | call doTesselate() 45 | end if 46 | 47 | contains 48 | 49 | recursive subroutine doTesselate() 50 | real(wp),dimension(2,3)::mxi,txi 51 | 52 | mxi(:,1) = (lxi(:,1)+lxi(:,2))/2.0_wp 53 | mxi(:,2) = (lxi(:,2)+lxi(:,3))/2.0_wp 54 | mxi(:,3) = (lxi(:,3)+lxi(:,1))/2.0_wp 55 | 56 | txi = reshape([lxi(:,1),mxi(:,1),mxi(:,3)],[2,3]) 57 | call fillTriangle(e,xy,f,fR,txi,ldepth+1) 58 | 59 | txi = reshape([mxi(:,1),lxi(:,2),mxi(:,2)],[2,3]) 60 | call fillTriangle(e,xy,f,fR,txi,ldepth+1) 61 | 62 | txi = reshape([mxi(:,3),mxi(:,2),lxi(:,3)],[2,3]) 63 | call fillTriangle(e,xy,f,fR,txi,ldepth+1) 64 | 65 | txi = reshape([mxi(:,1),mxi(:,2),mxi(:,3)],[2,3]) 66 | call fillTriangle(e,xy,f,fR,txi,ldepth+1) 67 | end subroutine doTesselate 68 | 69 | end subroutine fillTriangle 70 | 71 | end module plotMesh_mod 72 | 73 | program testMesh_prg 74 | !! Test program for mesh_mod 75 | use mesh_mod 76 | use plplotlib_mod 77 | use array_mod 78 | use plotMesh_mod 79 | implicit none 80 | 81 | type(mesh_t)::m 82 | real(wp),dimension(:),allocatable::s 83 | real(wp),dimension(:,:),allocatable::v 84 | 85 | call setup(fileName='testsMesh-%n.svg',figSize=[400,300]) 86 | call testReadGmsh 87 | call testWriteVTK 88 | call testShapeFunctions 89 | call show() 90 | 91 | contains 92 | 93 | subroutine testReadGmsh 94 | !! Verify operation of readGmsh 95 | 96 | call execute_command_line('gmsh -2 ./input/square.geo -o square.msh -format msh2') 97 | call m%readGmsh('square.msh') 98 | end subroutine testReadGmsh 99 | 100 | subroutine testWriteVTK 101 | !! Verify operation of writeVTK 102 | integer::N,k 103 | 104 | N = size(m%nodes) 105 | allocate( s(N) , v(N,3) ) 106 | v(:,3) = 0.0_wp 107 | do k=1,N 108 | s(k) = norm2( m%nodes(k)%x ) 109 | v(k,1:2) = m%nodes(k)%x 110 | end do 111 | 112 | call m%writeVTK('square.vtk') 113 | call m%appendScalarVTK('square.vtk',s,'s') 114 | call m%appendVectorVTK('square.vtk',v,'v') 115 | end subroutine testWriteVTK 116 | 117 | subroutine testShapeFunctions 118 | !! Verify operation of element shape functions 119 | 120 | real(wp),dimension(:),allocatable::x,y 121 | real(wp),dimension(:),allocatable::ex,ey 122 | real(wp),dimension(:),allocatable::lx,ly 123 | real(wp),dimension(:,:),allocatable::lxy 124 | type(element_t)::e 125 | integer::k 126 | 127 | x = m%nodes(:)%x(1) 128 | y = m%nodes(:)%x(2) 129 | 130 | call figure() 131 | call subplot(1,1,1,aspect=span(y)/span(x)) 132 | call xylim(mixval(x),mixval(y)+0.05_wp*[-1.0_wp,1.0_wp*span(y)]) 133 | 134 | do k=1,size(m%elements) 135 | e = m%elements(k) 136 | if(.not.any(e%etype==[ET_TRIANGLE_1,ET_TRIANGLE_2])) cycle 137 | ex = m%nodes(e%nodes)%x(1) 138 | ey = m%nodes(e%nodes)%x(2) 139 | lxy = transpose(reshape([ex,ey],[size(ex),2])) 140 | call fillTriangle(e,lxy,exampleFunction(ex,ey),[-1.0_wp,1.0_wp]) 141 | end do 142 | 143 | do k=1,size(m%elements) 144 | e = m%elements(k) 145 | if(.not.any(e%etype==[ET_TRIANGLE_1,ET_TRIANGLE_2])) cycle 146 | ex = m%nodes(e%nodes)%x(1) 147 | ey = m%nodes(e%nodes)%x(2) 148 | 149 | lx = ex([1,2,3,1]) 150 | ly = ey([1,2,3,1]) 151 | call plot(lx,ly,lineStyle='-',lineColor='k',lineWidth=2.0_wp) 152 | end do 153 | call plot(x,y,lineStyle='',markStyle='s',markColor='C1',markSize=4.0_wp) 154 | 155 | call ticks() 156 | call labels('x','y','') 157 | call colorbar(reshape([-1.0_wp,1.0_wp],[2,1]),10,'','') 158 | end subroutine testShapeFunctions 159 | 160 | elemental function exampleFunction(x,y) result(o) 161 | real(wp),intent(in)::x,y 162 | real(wp)::o 163 | 164 | o = x*y 165 | end function exampleFunction 166 | 167 | end program testMesh_prg 168 | -------------------------------------------------------------------------------- /src/test/testNetCDF.f90: -------------------------------------------------------------------------------- 1 | program testNetCDF_prg 2 | !! Test program for netCFD_mod 3 | use netCDF_mod 4 | use array_mod 5 | implicit none 6 | 7 | call testWrite 8 | call testRead 9 | 10 | contains 11 | 12 | subroutine testWrite 13 | !! Test writing netCDF files 14 | real(wp),dimension(:),allocatable::x,y 15 | real(wp),dimension(:,:),allocatable::XX,YY,F 16 | 17 | x = linspace(0.0_wp,1.0_wp,100) 18 | y = linspace(0.0_wp,1.0_wp,101) 19 | 20 | XX = meshGridX(x,y) 21 | YY = meshGridY(x,y) 22 | 23 | F = XX*YY 24 | 25 | call writeGrid('data.nc',['F'],x,y) 26 | call writeStep('data.nc',0.0_wp,1,'F',F) 27 | end subroutine testWrite 28 | 29 | subroutine testRead 30 | !! Test reading netCDF files 31 | !! May fail due to write failure 32 | logical,dimension(1)::results 33 | real(wp),dimension(:),allocatable::x,y,z,t 34 | real(wp),dimension(:,:),allocatable::XX,YY,F 35 | character(3),dimension(:),allocatable::vars 36 | 37 | call readGrid('data.nc',vars,x,y,z,t) 38 | allocate(F(size(x),size(y))) 39 | call readStep('data.nc',trim(adjustl(vars(1))),F,1) 40 | 41 | XX = meshGridX(x,y) 42 | YY = meshGridY(x,y) 43 | 44 | results(1) = norm2(F-XX*YY)<1.0E-10_wp 45 | 46 | if( .not.any(results) ) error stop "Failed testRead[Write] check" 47 | end subroutine testRead 48 | 49 | end program testNetCDF_prg 50 | -------------------------------------------------------------------------------- /src/test/testOptimize.f90: -------------------------------------------------------------------------------- 1 | module objective_mod 2 | use optimize_mod 3 | use autoDiff_mod 4 | implicit none 5 | 6 | integer::kLog = 1 7 | real(wp),dimension(1000,2)::xLog 8 | 9 | type,extends(obj_t)::test_t 10 | real(wp),private::b = -1.0_wp 11 | contains 12 | procedure::eval => eval_test 13 | end type 14 | 15 | type,extends(objN_t)::testN_t 16 | real(wp),dimension(2)::c0 = [2.0_wp,3.0_wp] 17 | real(wp),dimension(2)::s0 = [1.0_wp,2.0_wp] 18 | contains 19 | procedure::eval => eval_testN 20 | end type 21 | 22 | type,extends(objN_t)::testNa_t 23 | real(wp),dimension(2)::c0 = [2.0_wp,3.0_wp] 24 | real(wp),dimension(2)::s0 = [1.0_wp,2.0_wp] 25 | contains 26 | procedure::eval => eval_testNa 27 | procedure::grad => grad_testNa 28 | end type 29 | 30 | contains 31 | 32 | function eval_test(self,x) result(o) 33 | class(test_t),intent(in)::self 34 | real(wp),intent(in)::x 35 | real(wp)::o 36 | 37 | o = x**2-self%b 38 | end function eval_test 39 | 40 | function eval_testN(self,x) result(o) 41 | class(testN_t),intent(in)::self 42 | real(wp),dimension(:),intent(in)::x 43 | !! Must be dimension(2) 44 | real(wp)::o 45 | 46 | if( kLog<=size(xLog,1) ) then 47 | xLog(kLog,1:2) = x(1:2) 48 | kLog = kLog+1 49 | end if 50 | 51 | o = norm2( (x(1:2)-self%c0)*self%s0 )**2-1.0_wp 52 | end function eval_testN 53 | 54 | function eval_testNa(self,x) result(o) 55 | class(testNa_t),intent(in)::self 56 | real(wp),dimension(:),intent(in)::x 57 | !! Must be dimension(2) 58 | real(wp)::o 59 | 60 | if( kLog<=size(xLog,1) ) then 61 | xLog(kLog,1:2) = x(1:2) 62 | kLog = kLog+1 63 | end if 64 | 65 | o = norm2( (x(1:2)-self%c0)*self%s0 )**2-1.0_wp 66 | end function eval_testNa 67 | 68 | function grad_testNa(self,x) result(o) 69 | class(testNa_t),intent(in)::self 70 | real(wp),dimension(:),intent(in)::x 71 | !! Must be dimension(2) 72 | real(wp),dimension(:),allocatable::o 73 | 74 | type(ad_t),dimension(2)::ax 75 | type(ad_t)::ao 76 | 77 | if( kLog<=size(xLog,1) ) then 78 | xLog(kLog,1:2) = x(1:2) 79 | kLog = kLog+1 80 | end if 81 | 82 | ax(1) = ad_t( x(1) , 2 , 1 ) 83 | ax(2) = ad_t( x(2) , 2 , 2 ) 84 | 85 | ao = norm2( (ax(1:2)-self%c0)*self%s0 )**2-1.0_wp 86 | 87 | o = ao%grad() 88 | end function grad_testNa 89 | 90 | end module objective_mod 91 | 92 | program testOptimize_prg 93 | !! Test program for Optimize_mod 94 | !! @todo 95 | !! Finish tests 96 | use objective_mod 97 | use array_mod 98 | use plplotlib_mod 99 | use text_mod 100 | implicit none 101 | 102 | call testObjective 103 | call testObjectiveN 104 | call testPlot 105 | 106 | contains 107 | 108 | subroutine testObjective 109 | !! Verify operation of obj_t 110 | type(test_t)::test 111 | 112 | write(*,*) test%eval(2.0_wp)-3.0_wp 113 | write(*,*) test%der1(0.0_wp) 114 | write(*,*) test%der2(0.0_wp) 115 | write(*,*) test%rootNewton(4.0_wp,tol=1.0E-10_wp,maxIts=1000000) 116 | write(*,*) test%minNewton(4.0_wp,tol=1.0E-10_wp,maxIts=1000000) 117 | end subroutine testObjective 118 | 119 | subroutine testObjectiveN 120 | type(testNa_t)::test 121 | real(wp),dimension(:),allocatable::xSD,xMN,xNM 122 | 123 | xSD = test%steepestDescent([5.0_wp,5.0_wp]) 124 | xMN = test%minNewton([5.0_wp,5.0_wp]) 125 | xNM = test%nelderMead([5.0_wp,5.0_wp]) 126 | write(*,*) xSD 127 | write(*,*) xMN 128 | write(*,*) xNM 129 | end subroutine testObjectiveN 130 | 131 | subroutine testPlot 132 | type(testNa_t)::test 133 | real(wp),dimension(:),allocatable::x,y 134 | real(wp),dimension(:,:),allocatable::f 135 | integer::N,i,j 136 | 137 | real(wp),dimension(:),allocatable::xm 138 | 139 | N = 100 140 | x = linspace(0.0_wp,7.0_wp,N) 141 | y = linspace(0.0_wp,7.0_wp,N) 142 | allocate( f(N,N) ) 143 | 144 | do j=1,N 145 | do i=1,N 146 | f(i,j) = -test%eval([ x(i) , y(j) ]) 147 | end do 148 | end do 149 | 150 | call setup(device='pngcairo',fileName='testsOptimize-%n.png',figSize=[400,350]) 151 | 152 | kLog = 1 153 | xm = test%steepestDescent([5.0_wp,5.0_wp]) 154 | call figure() 155 | call subplot(1,1,1,aspect=span(y)/span(x)) 156 | call xylim(mixval(x),mixval(y)) 157 | call contourf(x,y,f,30) 158 | call plot(xLog(:kLog-1,1),xLog(:kLog-1,2),lineStyle='-',markStyle='x',markColor='k') 159 | call colorbar2(f,30) 160 | call ticks() 161 | call labels('x','y','Steepest Descent F['//intToChar(kLog-1)//']') 162 | 163 | kLog = 1 164 | xm = test%minNewton([5.0_wp,5.0_wp]) 165 | call figure() 166 | call subplot(1,1,1,aspect=span(y)/span(x)) 167 | call xylim(mixval(x),mixval(y)) 168 | call contourf(x,y,f,30) 169 | call plot(xLog(:kLog-1,1),xLog(:kLog-1,2),lineStyle='-',markStyle='x',markColor='k') 170 | call colorbar2(f,30) 171 | call ticks() 172 | call labels('x','y','Newton-Raphson G['//intToChar(kLog-1)//']') 173 | 174 | kLog = 1 175 | xm = test%nelderMead([5.0_wp,5.0_wp]) 176 | call figure() 177 | call subplot(1,1,1,aspect=span(y)/span(x)) 178 | call xylim(mixval(x),mixval(y)) 179 | call contourf(x,y,f,30) 180 | call plot(xLog(:kLog-1,1),xLog(:kLog-1,2),lineStyle='-',markStyle='x',markColor='k') 181 | call colorbar2(f,30) 182 | call ticks() 183 | call labels('x','y','Nelder-Mead Simplex F['//intToChar(kLog-1)//']') 184 | 185 | call show() 186 | 187 | end subroutine testPlot 188 | 189 | end program testOptimize_prg 190 | -------------------------------------------------------------------------------- /src/test/testQuaternion.f90: -------------------------------------------------------------------------------- 1 | program testQuaternion_prg 2 | !! Test program for quaternion_mod 3 | !! @todo 4 | !! Add real tests 5 | use quaternion_mod 6 | implicit none 7 | 8 | call testBasic 9 | 10 | contains 11 | 12 | subroutine testBasic 13 | type(quat_t)::u,v,w 14 | 15 | u%s = 1.0_wp 16 | v%s = 2.0_wp 17 | 18 | w = u*v 19 | 20 | write(*,*) scaler(w),vector(w) 21 | write(*,*) w%getRotationMatrix() 22 | end subroutine testBasic 23 | 24 | end program testQuaternion_prg 25 | -------------------------------------------------------------------------------- /src/test/testSparse.f90: -------------------------------------------------------------------------------- 1 | program testSparse_prg 2 | use sparse_mod 3 | use basicSolvers_mod 4 | use solvers_mod 5 | use array_mod 6 | use plplotlib_mod 7 | implicit none 8 | 9 | call setup(fileName='testsSparse-%n.svg',figSize=[400,300]) 10 | call testNewSparse 11 | call testSpvec 12 | call testBasicSolvers 13 | call testSolvers 14 | call show() 15 | 16 | contains 17 | 18 | subroutine testNewSparse 19 | type(sparse_t)::A 20 | integer::N,M 21 | 22 | N = 3 23 | M = 5 24 | 25 | A = sparse_t(N,M) 26 | end subroutine testNewSparse 27 | 28 | subroutine testSpvec 29 | type(spvec_t)::u,v,r 30 | 31 | u%i = [1,2,3] 32 | u%v = [1.0_wp,2.0_wp,3.0_wp] 33 | 34 | v%i = [2,3,4] 35 | v%v = [2.0_wp,3.0_wp,4.0_wp] 36 | 37 | write(*,*) u.o.v 38 | 39 | r = u+v 40 | write(*,*) r%i 41 | write(*,*) r%v 42 | 43 | r = 2.0_wp*u*2.0_wp 44 | write(*,*) r%i 45 | write(*,*) r%v 46 | end subroutine testSpvec 47 | 48 | subroutine testBasicSolvers 49 | real(wp),parameter::Tl = 0.0_wp 50 | real(wp),parameter::Tr = 1.0_wp 51 | real(wp),parameter::k = 1.0_wp 52 | real(wp),parameter::q0 = 10.0_wp 53 | real(wp),parameter::tol = 1.0E-8_wp 54 | 55 | real(wp)::Ap,Ae,Aw,dx 56 | type(sparse_t)::A 57 | real(wp),dimension(:),allocatable::x,q 58 | real(wp),dimension(:),allocatable::T1,T2,T3 59 | integer::N,i,s 60 | 61 | N = 1000 62 | s = N/30 63 | allocate(x(0:N+1)) 64 | x = linspace(0.0_wp,1.0_wp,N+2) 65 | q = [( q0 , i=1,N )] 66 | A = sparse_t(N,N) 67 | 68 | allocate(T1(0:N+1)) 69 | allocate(T2(0:N+1)) 70 | allocate(T3(0:N+1)) 71 | 72 | T1(0) = Tl 73 | T1(N+1) = Tr 74 | 75 | T2(0) = Tl 76 | T2(N+1) = Tr 77 | 78 | T3(0) = Tl 79 | T3(N+1) = Tr 80 | 81 | dx = x(2)-x(1) 82 | 83 | i = 1 84 | Ae = k/dx**2 85 | Aw = k/dx**2 86 | Ap = Ae+Aw 87 | call A%set(i,i , Ap) 88 | call A%set(i,i+1,-Ae) 89 | q(i) = q(i)+Aw*Tl 90 | do i=2,N-1 91 | Ae = k/dx**2 92 | Aw = k/dx**2 93 | Ap = Ae+Aw 94 | call A%set(i,i-1,-Aw) 95 | call A%set(i,i , Ap) 96 | call A%set(i,i+1,-Ae) 97 | end do 98 | i = N 99 | Ae = k/dx**2 100 | Aw = k/dx**2 101 | Ap = Ae+Aw 102 | call A%set(i,i-1,-Aw) 103 | call A%set(i,i , Ap) 104 | q(i) = q(i)+Ae*Tr 105 | 106 | T1(1:N) = biConjugateGradientStabilized(A,q) 107 | T2(1:N) = conjugateGradient(A,q) 108 | T3(1:N) = successiveOverRelaxation(A,q,1.995_wp) 109 | 110 | 111 | call figure() 112 | call subplot(1,1,1) 113 | call xylim(mixval(x),mixval(T1)+[0.0_wp,0.05_wp]*span(T1)) 114 | call plot(x(::s),T1(::s),lineStyle='-',lineColor='C1',markStyle='x',markColor='C1') 115 | call plot(x(::s),T2(::s),lineStyle='-',lineColor='C0',markStyle='o',markColor='C0') 116 | call plot(x(::s),T3(::s),lineStyle='-',lineColor='C2',markStyle='s',markColor='C2') 117 | call ticks() 118 | call labels('Position #fix#fn','Temperature #fiT#fn','1D Heat Conduction with Generation') 119 | 120 | end subroutine testBasicSolvers 121 | 122 | subroutine testSolvers 123 | real(wp),parameter::Tl = 0.0_wp 124 | real(wp),parameter::Tr = 1.0_wp 125 | real(wp),parameter::k = 1.0_wp 126 | real(wp),parameter::q0 = 10.0_wp 127 | real(wp),parameter::tol = 1.0E-8_wp 128 | 129 | real(wp)::Ap,Ae,Aw,dx 130 | type(sparse_t)::A 131 | class(solver_t),allocatable::solver 132 | real(wp),dimension(:),allocatable::x,q 133 | real(wp),dimension(:),allocatable::T1 134 | integer::N,i,s 135 | 136 | N = 100 137 | s = N/30 138 | allocate(x(0:N+1)) 139 | x = linspace(0.0_wp,1.0_wp,N+2) 140 | q = [( q0 , i=1,N )] 141 | A = sparse_t(N,N) 142 | 143 | allocate(T1(0:N+1)) 144 | 145 | T1(0) = Tl 146 | T1(N+1) = Tr 147 | 148 | dx = x(2)-x(1) 149 | 150 | i = 1 151 | Ae = k/dx**2 152 | Aw = k/dx**2 153 | Ap = Ae+Aw 154 | call A%set(i,i , Ap) 155 | call A%set(i,i+1,-Ae) 156 | q(i) = q(i)+Aw*Tl 157 | do i=2,N-1 158 | Ae = k/dx**2 159 | Aw = k/dx**2 160 | Ap = Ae+Aw 161 | call A%set(i,i-1,-Aw) 162 | call A%set(i,i , Ap) 163 | call A%set(i,i+1,-Ae) 164 | end do 165 | i = N 166 | Ae = k/dx**2 167 | Aw = k/dx**2 168 | Ap = Ae+Aw 169 | call A%set(i,i-1,-Aw) 170 | call A%set(i,i , Ap) 171 | q(i) = q(i)+Ae*Tr 172 | 173 | allocate(solver,source=jacobi_t()) 174 | call solver%setup(A) 175 | T1(1:N) = solver%solve(A,q) 176 | deallocate(solver) 177 | 178 | allocate(solver,source=gaussSeidel_t()) 179 | call solver%setup(A) 180 | T1(1:N) = solver%solve(A,q) 181 | deallocate(solver) 182 | 183 | allocate(solver,source=SOR_t(1.99_wp)) 184 | call solver%setup(A) 185 | T1(1:N) = solver%solve(A,q) 186 | deallocate(solver) 187 | 188 | allocate(solver,source=conjugateGradient_t()) 189 | call solver%setup(A) 190 | T1(1:N) = solver%solve(A,q) 191 | deallocate(solver) 192 | 193 | allocate(solver,source=biCGSTAB_t()) 194 | call solver%setup(A) 195 | T1(1:N) = solver%solve(A,q) 196 | deallocate(solver) 197 | 198 | call figure() 199 | call subplot(1,1,1) 200 | call xylim(mixval(x),mixval(T1)+[0.0_wp,0.05_wp]*span(T1)) 201 | call plot(x(::s),T1(::s),lineStyle='-',lineColor='k',markStyle='x',markColor='C1') 202 | call ticks() 203 | call labels('Position #fix#fn','Temperature #fiT#fn','1D Heat Conduction with Generation') 204 | 205 | end subroutine testSolvers 206 | 207 | end program testSparse_prg 208 | -------------------------------------------------------------------------------- /src/test/testSpline.f90: -------------------------------------------------------------------------------- 1 | program testSpline_prg 2 | !! Test program for Spline_mod 3 | use spline_mod 4 | use plplotlib_mod 5 | use array_mod 6 | implicit none 7 | 8 | real(wp),dimension(5,2),parameter::x0 = reshape( [ & 9 | & -2.0_wp,-1.0_wp, 0.0_wp,1.0_wp,2.0_wp , & 10 | & 3.0_wp, 0.0_wp,-1.0_wp,0.0_wp,3.0_wp & 11 | & ],[5,2]) 12 | 13 | real(wp),dimension(5),parameter::t0 = & 14 | & [ 0.00_wp,0.25_wp,0.50_wp,0.75_wp,1.00_wp] 15 | 16 | call testNewSpline 17 | call testSplineX 18 | 19 | contains 20 | 21 | subroutine testNewSpline 22 | type(cubicSpline_t)::spline 23 | 24 | spline = cubicSpline_t(t0,x0) 25 | end subroutine testNewSpline 26 | 27 | subroutine testSplineX 28 | type(cubicSpline_t)::sf,sc 29 | type(linearSpline_t)::sl 30 | real(wp),dimension(:,:),allocatable::xl,xf,xc,xt 31 | real(wp)::t 32 | integer::N,k 33 | 34 | N = 100 35 | 36 | sl = linearSpline_t(t0,x0) 37 | sf = cubicSpline_t(t0,x0,'finiteDifference') 38 | sc = cubicSpline_t(t0,x0,'conventional') 39 | 40 | allocate( xl(N,2) , xf(N,2) , xc(N,2) , xt(N,2) ) 41 | 42 | do k=1,N 43 | t = real(k-1,wp)/real(N-1,wp) 44 | xl(k,1:2) = sl%x(t) 45 | xf(k,1:2) = sf%x(t) 46 | xc(k,1:2) = sc%x(t) 47 | xt(k,1:2) = [4.0_wp*t-2.0_wp,(4.0_wp*t-2.0_wp)**2-1.0_wp] 48 | end do 49 | 50 | call setup(fileName='spline-%n.svg',figSize=[400,300]) 51 | 52 | call figure() 53 | call subplot(1,1,1) 54 | call xylim(mixval(xt(:,1)),mixval(xt(:,2))) 55 | 56 | call plot(xt(:,1),xt(:,2),lineStyle='-' ,lineColor='C1',lineWidth=2.0_wp) 57 | call plot(xl(:,1),xl(:,2),lineStyle=':' ,lineColor='C3',lineWidth=2.0_wp) 58 | call plot(xf(:,1),xf(:,2),lineStyle='-' ,lineColor='C0',lineWidth=2.0_wp) 59 | call plot(xc(:,1),xc(:,2),lineStyle='--',lineColor='C2',lineWidth=2.0_wp) 60 | call plot(x0(:,1),x0(:,2),lineStyle='' ,markStyle='x',markColor='k') 61 | 62 | call ticks() 63 | call labels('x','y','Spline Test') 64 | 65 | call figure() 66 | call subplot(1,1,1) 67 | call xylim(mixval(xt(:,1)),[-2.0_wp,2.0_wp]) 68 | 69 | call plot(xl(:,1),xl(:,2)-xt(:,2),lineStyle=':' ,lineColor='C1',lineWidth=2.0_wp) 70 | call plot(xt(:,1),xt(:,2)-xt(:,2),lineStyle='-' ,lineColor='C3',lineWidth=2.0_wp) 71 | call plot(xf(:,1),xf(:,2)-xt(:,2),lineStyle='-' ,lineColor='C0',lineWidth=2.0_wp) 72 | call plot(xc(:,1),xc(:,2)-xt(:,2),lineStyle='--',lineColor='C2',lineWidth=2.0_wp) 73 | call plot(x0(:,1),x0(:,2)-x0(:,2),lineStyle='' ,markStyle='x',markColor='k') 74 | 75 | call ticks() 76 | call labels('x','y','Spline Test') 77 | 78 | call show() 79 | end subroutine testSplineX 80 | 81 | end program testSpline_prg 82 | -------------------------------------------------------------------------------- /src/test/testStats.f90: -------------------------------------------------------------------------------- 1 | program testStats_prg 2 | !! Test program for stats_mod 3 | use array_mod 4 | use constants_mod 5 | use stats_mod 6 | implicit none 7 | 8 | call testSetRandomSeed 9 | call testRandomUniform 10 | call testRandomNormal 11 | 12 | call testMean 13 | call testStDev 14 | 15 | call testKDE 16 | 17 | contains 18 | 19 | subroutine testSetRandomSeed 20 | !! Test setRandomSeed to verify operation 21 | logical,dimension(2)::results 22 | 23 | integer,parameter::N = 10 24 | real(wp),dimension(N)::x,y,z 25 | 26 | call setRandomSeed(1) 27 | call random_number(x) 28 | 29 | call setRandomSeed(2) 30 | call random_number(y) 31 | 32 | call setRandomSeed(1) 33 | call random_number(z) 34 | 35 | results(1) = any(x==y) 36 | results(2) = .not.all(x==z) 37 | 38 | if( any(results) ) error stop "Failed setRandomSeed check" 39 | end subroutine testSetRandomSeed 40 | 41 | subroutine testRandomUniform 42 | !! Test randomUniform to verify approximate distribution properties 43 | logical,dimension(4)::results 44 | 45 | integer,parameter::N = 1000000 46 | real(wp),dimension(N)::x 47 | 48 | call setRandomSeed(1) 49 | x = randomUniform(N) 50 | 51 | results(1) = abs(mean(x))>5.0E-3_wp 52 | results(2) = abs(stDev(x)-sqrt(3.0_wp)**(-1))>5.0E-3_wp 53 | results(3) = any(x> 1.0_wp+epsilon(1.0_wp)) 54 | results(4) = any(x<-1.0_wp-epsilon(1.0_wp)) 55 | 56 | if( any(results) ) error stop "Failed randomUniform check" 57 | end subroutine testRandomUniform 58 | 59 | subroutine testRandomNormal 60 | !! Test randomNormal to verify approximate distribution properties 61 | logical,dimension(4)::results 62 | 63 | integer,parameter::N = 1000000 64 | real(wp),dimension(N)::x 65 | 66 | call setRandomSeed(1) 67 | x = randomNormal(N) 68 | 69 | results(1) = abs(mean(x))>5.0E-3_wp 70 | results(2) = abs(stdev(x)-1.0_wp)>5.0E-3_wp 71 | results(3) = any(x> 6.0_wp+12.0_wp*epsilon(1.0_wp)) 72 | results(4) = any(x<-6.0_wp-12.0_wp*epsilon(1.0_wp)) 73 | 74 | if( any(results) ) error stop "Failed randomNormal check" 75 | end subroutine testRandomNormal 76 | 77 | subroutine testMean 78 | !! Test mean to verify operation 79 | logical,dimension(1)::results 80 | 81 | results(1) = abs(mean([0.0_wp,1.0_wp,2.0_wp,3.0_wp,4.0_wp])-2.0_wp)<2.0_wp**4*epsilon(1.0_wp) 82 | 83 | if( .not.all(results) ) error stop "Failed mean check" 84 | end subroutine testMean 85 | 86 | subroutine testStDev 87 | !! Test stDev to verify operation 88 | logical,dimension(1)::results 89 | 90 | results(1) = abs(stDev([-1.0_wp,0.0_wp,1.0_wp])-1.0_wp)<2.0_wp**4*epsilon(1.0_wp) 91 | 92 | if( .not.all(results) ) error stop "Failed mean check" 93 | end subroutine testStDev 94 | 95 | subroutine testKDE 96 | !! Test KDE to verify operation 97 | 98 | real(wp),dimension(:),allocatable::s,x,y,t 99 | 100 | x = linspace(-6.0_wp,6.0_wp,100) 101 | s = randomNormal(1000*000) 102 | y = KDE(s,x) 103 | t = 1.0_wp/(2.0_wp*PI)*exp(-0.5_wp*x**2) 104 | 105 | if( norm2(t-y)>1.0_wp ) error stop "Failed KDE check" 106 | end subroutine testKDE 107 | 108 | end program testStats_prg 109 | -------------------------------------------------------------------------------- /src/test/testTensor.f90: -------------------------------------------------------------------------------- 1 | program testTensor_prg 2 | !! Test program for Tensor_mod 3 | use tensor_mod 4 | implicit none 5 | 6 | call testDot 7 | 8 | contains 9 | 10 | subroutine testDot 11 | !! Verify operation of Dot and Dyadic 12 | real(wp),dimension(3)::u,v 13 | real(wp),dimension(3,3)::D 14 | real(wp)::r 15 | 16 | u = [1.0_wp,2.0_wp,0.0_wp] 17 | v = [0.0_wp,2.0_wp,3.0_wp] 18 | 19 | r = u.o.v 20 | D = u.d.v 21 | end subroutine testDot 22 | 23 | end program testTensor_prg 24 | -------------------------------------------------------------------------------- /src/test/testText.f90: -------------------------------------------------------------------------------- 1 | program testText_prg 2 | !! Test program for text_mod 3 | use text_mod 4 | implicit none 5 | 6 | call testRemoveSpaces 7 | 8 | call testStartsWith 9 | call testEndsWith 10 | 11 | call testIntToChar 12 | call testRealToChar 13 | call testRealToTime 14 | 15 | call testColorize 16 | call testColorMap 17 | 18 | contains 19 | 20 | subroutine testRemoveSpaces 21 | !! Test removeSpaces to verify operation 22 | !! @todo 23 | !! Make me a test with stop conditions 24 | character(:),allocatable::s1,s2 25 | 26 | s1 = 'This Is A Test' 27 | s2 = removeSpaces(s1) 28 | 29 | write(*,*) '|'//s2//'|' 30 | end subroutine testRemoveSpaces 31 | 32 | subroutine testStartsWith 33 | !! Test startsWith to verify operation 34 | logical,dimension(4)::results 35 | 36 | results(1) = startsWith('thisFunction','this') 37 | results(2) = .not.startsWith('thisFunction','that') 38 | results(3) = .not.startsWith('','this') 39 | results(4) = startsWith('thisFunction','') 40 | 41 | if( .not.all(results) ) error stop "Failed startsWith check" 42 | end subroutine testStartsWith 43 | 44 | subroutine testEndsWith 45 | !! Test endsWith to verify operation 46 | logical,dimension(4)::results 47 | 48 | results(1) = endsWith('thisFunction','Function') 49 | results(2) = .not.endsWith('thisFunction','Subroutine') 50 | results(3) = .not.endsWith('','this') 51 | results(4) = endsWith('thisFunction','') 52 | 53 | if( .not.all(results) ) error stop "Failed endsWith check" 54 | end subroutine testEndsWith 55 | 56 | subroutine testIntToChar 57 | !! Test intToChar to verify operation 58 | logical,dimension(4)::results 59 | 60 | results(1) = intToChar(1)=='1' 61 | results(2) = intToChar(-1)=='-1' 62 | results(3) = intToChar(1,'(1I4.4)')=='0001' 63 | results(4) = intToChar(1,'(1I4.4)',6)=='0001 ' 64 | 65 | if( .not.all(results) ) error stop "Failed intToChar check" 66 | end subroutine testIntToChar 67 | 68 | subroutine testRealToChar 69 | !! Test realToChar to verify operation 70 | logical,dimension(2)::results 71 | 72 | results(1) = realToChar(1.0_wp,'(1F10.5)')=='1.00000' 73 | results(2) = realToChar(1.0_wp,'(1F10.5)',20)=='1.00000 ' 74 | 75 | if( .not.all(results) ) error stop "Failed realToChar check" 76 | end subroutine testRealToChar 77 | 78 | subroutine testRealToTime 79 | !! Test realToTime to verify operation 80 | logical,dimension(1)::results 81 | 82 | results(1) = realToTime(3600.0_wp*24.0_wp+3600.0_wp*2.0_wp+60.0_wp*3.0_wp+4.0_wp)=='1d 2h 3m 4s' 83 | 84 | if( .not.all(results) ) error stop "Failed realToTime check" 85 | end subroutine testRealToTime 86 | 87 | subroutine testColorize 88 | !! Test colorize to verify operation 89 | character(:),allocatable::test,true 90 | 91 | character(1),parameter::ESC = achar(27) 92 | 93 | test = colorize('white',[5,5,5]) 94 | true = ESC//'[38;5;'//'231'//'m'//'white'//ESC//'[0m' 95 | 96 | if( .not.(test==true) ) error stop "Failed colorize check" 97 | end subroutine testColorize 98 | 99 | subroutine testColorMap 100 | !! Test colorMap to verify operation 101 | integer,parameter::N = 11 102 | integer,dimension(N,3),parameter::true = & 103 | & reshape([ 0,1,2,3,4,5,5,5,5,5,5, & 104 | & 0,1,2,3,4,5,4,3,2,1,0, & 105 | & 5,5,5,5,5,5,4,3,2,1,0 ],[N,3]) 106 | real(wp),dimension(2),parameter::R = [0.0_wp,1.0_wp] 107 | 108 | integer,dimension(N,3)::test 109 | real(wp)::x 110 | integer::k 111 | 112 | do k=1,N 113 | x = real(k-1,wp)/real(N-1,wp) 114 | test(k,1:3) = colorMap(x,R) 115 | end do 116 | 117 | if( .not.all(true==test) ) error stop "Failed colorMap check" 118 | end subroutine testColorMap 119 | 120 | end program testText_prg 121 | -------------------------------------------------------------------------------- /src/test/testTime.f90: -------------------------------------------------------------------------------- 1 | program testTime_prg 2 | !! Test program for time_mod 3 | use time_mod 4 | implicit none 5 | 6 | call testCpuTime 7 | call testWallTime 8 | 9 | contains 10 | 11 | subroutine testCpuTime 12 | !! Test cpuTime to verify operation 13 | real(wp)::t0,t1 14 | 15 | t0 = cpuTime() 16 | call wait(0.1_wp) 17 | t1 = cpuTime() 18 | 19 | if( t1-t0>0.01_wp ) error stop "Failed cpuTime check" 20 | end subroutine testCpuTime 21 | 22 | subroutine testWallTime 23 | !! Test wallTime to verify operation 24 | real(wp)::t0,t1 25 | 26 | t0 = wallTime() 27 | call wait(0.1_wp) 28 | t1 = wallTime() 29 | 30 | if( t1-t0<0.1_wp ) error stop "Failed wallTime check" 31 | end subroutine testWallTime 32 | 33 | end program testTime_prg 34 | -------------------------------------------------------------------------------- /src/test/testUnits.f90: -------------------------------------------------------------------------------- 1 | program testUnits_prg 2 | !! Test program for units_mod 3 | !! @todo 4 | !! Needs serious improvements 5 | use units_mod 6 | use constants_mod 7 | implicit none 8 | 9 | call testUnits 10 | 11 | contains 12 | 13 | subroutine testUnits 14 | type(quantity_t)::dP 15 | type(quantity_t)::rho 16 | type(quantity_t)::V 17 | type(quantity_t)::A 18 | type(quantity_t)::D 19 | type(quantity_t)::F 20 | type(quantity_t)::P 21 | 22 | rho = quantity_t(1.225_wp,'kg')/quantity_t(1.0_wp,'m')**3 23 | dP = quantity_t(7.25E-2_wp,'psi') 24 | V = sqrt(2.0_wp*dP/rho) 25 | 26 | D = quantity_t(3.5_wp,'in') 27 | A = PI*D**2/4.0_wp 28 | F = A*dP 29 | P = V*F 30 | write(*,*) P%value,P%getChar() 31 | P = P%convert( quantity_t(1.0_wp,'W') ) 32 | write(*,*) P%value,P%getChar() 33 | end subroutine testUnits 34 | 35 | end program testUnits_prg 36 | 37 | -------------------------------------------------------------------------------- /src/test/testVtkIO.f90: -------------------------------------------------------------------------------- 1 | program testVtkIO_prg 2 | !! Test program for vtkIO_mod 3 | use vtkIO_mod 4 | use array_mod 5 | implicit none 6 | 7 | call testWriteVTK 8 | 9 | contains 10 | 11 | subroutine testWriteVTK 12 | !! Test writing VTK files 13 | 14 | real(wp),dimension(:),allocatable::x,y 15 | real(wp),dimension(:,:),allocatable::XX,YY 16 | real(wp),dimension(:,:),allocatable::F,U,V 17 | integer::N,M,iou 18 | 19 | N = 100 20 | M = 101 21 | 22 | x = linspace(0.0_wp,1.0_wp,N) 23 | y = linspace(0.0_wp,1.0_wp,M) 24 | 25 | XX = MeshGridX(x,y) 26 | YY = MeshGridY(x,y) 27 | 28 | F = XX*YY 29 | U = -YY 30 | V = XX 31 | 32 | open(file='data.vtk',newunit=iou) 33 | call writeHeaderVTK(iou,'Test File') 34 | call writeGridVTK(iou,XX,YY) 35 | call writeScalarVTK(iou,'F',F) 36 | call writeVectorVTK(iou,'U',U,V) 37 | close(iou) 38 | end subroutine testWriteVTK 39 | 40 | end program testVtkIO_prg 41 | -------------------------------------------------------------------------------- /src/time.f90: -------------------------------------------------------------------------------- 1 | module time_mod 2 | !! Timing module 3 | use kinds_mod 4 | use iso_c_binding 5 | implicit none 6 | private 7 | 8 | public::cpuTime 9 | public::wallTime 10 | public::wait 11 | 12 | ! Types 13 | public::wp 14 | 15 | contains 16 | 17 | function cpuTime() result(o) 18 | !! Return the cpu time to within an added constant (excludes sleep time) 19 | real(wp)::o 20 | 21 | call cpu_time(o) 22 | end function cpuTime 23 | 24 | function wallTime() result(o) 25 | !! Return the wall time to within an added constant (includes sleep time) 26 | real(wp)::o 27 | 28 | integer,parameter::ip = selected_int_kind(15) 29 | integer(ip)::ticks,tickRate,r 30 | 31 | call system_clock(ticks,tickRate) 32 | 33 | r = mod(ticks,tickRate) 34 | 35 | o = real(ticks/tickRate,wp)+real(r,wp)/real(tickRate,wp) 36 | end function wallTime 37 | 38 | subroutine wait(dt) 39 | !! Make the thread sleep 40 | real(wp),intent(in)::dt 41 | !! Time to sleep in seconds 42 | 43 | integer(c_int)::usec 44 | integer(c_int)::ret 45 | 46 | interface 47 | function doSleep(usec) result(e) bind(C,name='usleep') 48 | use iso_c_binding 49 | integer(c_int),value::usec 50 | integer(c_int)::e 51 | end function doSleep 52 | end interface 53 | 54 | usec = nint(dt*1.0E6) 55 | ret = doSleep(usec) 56 | end subroutine wait 57 | 58 | end module time_mod 59 | --------------------------------------------------------------------------------